升级到Office365 ProPlus后，Excel VBA运行极其缓慢 [英] Excel VBA running extremely slow after upgraded to Office365 ProPlus
本文介绍了升级到Office365 ProPlus后，Excel VBA运行极其缓慢的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我将部分代码粘贴如下.此代码用于解析从HTTP请求获得的JSON字符串，根本没有工作表/工作簿操作.在将Office升级到Office365 ProPlus之前，它非常高效.但是升级后，可以解析不到2秒的json需要花费几分钟.我个人不了解根本原因.
I paste part of the code as below. This code is to parse a JSON string got from HTTP request, there's no worksheet/workbook operation at all. Before office upgraded to office365 ProPlus, it's quite efficient. But after upgrade, a json which could be parsed less than 2 seconds, costs several minutes. Personally I don't understand the root cause.
代码源:@Tim Hall https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas
Code source: @Tim Hall https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas
' ============================================= '
' Public Methods
' ============================================= '
''
' Convert JSON string to object (Dictionary/Collection)
'
' @method ParseJson
' @param {String} json_String
' @return {Object} (Dictionary or Collection)
' @throws 10001 - JSON parse error
''
Public Function ParseJson(ByVal json_String As String) As Object
Dim json_Index As Long
json_Index = 1
' Remove vbCr, vbLf, and vbTab from json_String
json_String = VBA.Replace(VBA.Replace(VBA.Replace(json_String, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
json_SkipSpaces json_String, json_Index
Select Case VBA.Mid$(json_String, json_Index, 1)
Case "{"
Set ParseJson = json_ParseObject(json_String, json_Index)
Case "["
Set ParseJson = json_ParseArray(json_String, json_Index)
Case Else
' Error: Invalid JSON string
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{' or '['")
End Select
End Function
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
Dim json_Key As String
Dim json_NextChar As String
Set json_ParseObject = New Dictionary
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
Else
json_Index = json_Index + 1
Do
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) = "}" Then
json_Index = json_Index + 1
Exit Function
ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
json_Index = json_Index + 1
json_SkipSpaces json_String, json_Index
End If
json_Key = json_ParseKey(json_String, json_Index)
json_NextChar = json_Peek(json_String, json_Index)
Debug.Print "json_Key = " & json_Key & ", json_NextChar = " & json_NextChar
If json_NextChar = "[" Or json_NextChar = "{" Then
Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
Else
json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
End If
DoEvents
Loop
End If
End Function
Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
Set json_ParseArray = New Collection
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> "[" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['")
Else
json_Index = json_Index + 1
Do
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) = "]" Then
json_Index = json_Index + 1
Exit Function
ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
json_Index = json_Index + 1
json_SkipSpaces json_String, json_Index
End If
json_ParseArray.add json_ParseValue(json_String, json_Index)
'DoEvents
Loop
End If
End Function
Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
json_SkipSpaces json_String, json_Index
Select Case VBA.Mid$(json_String, json_Index, 1)
Case "{"
Set json_ParseValue = json_ParseObject(json_String, json_Index)
Case "["
Set json_ParseValue = json_ParseArray(json_String, json_Index)
Case """", "'"
json_ParseValue = json_ParseString(json_String, json_Index)
Case Else
If VBA.Mid$(json_String, json_Index, 4) = "true" Then
json_ParseValue = True
json_Index = json_Index + 4
ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then
json_ParseValue = False
json_Index = json_Index + 5
ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then
json_ParseValue = Null
json_Index = json_Index + 4
ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then
json_ParseValue = json_ParseNumber(json_String, json_Index)
Else
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['")
End If
End Select
End Function
Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
Dim json_Quote As String
Dim json_Char As String
Dim json_Code As String
Dim json_buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
json_SkipSpaces json_String, json_Index
' Store opening quote to look for matching closing quote
json_Quote = VBA.Mid$(json_String, json_Index, 1)
json_Index = json_Index + 1
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
Select Case json_Char
Case "\"
' Escaped string, \\, or \/
json_Index = json_Index + 1
json_Char = VBA.Mid$(json_String, json_Index, 1)
Select Case json_Char
Case """", "\", "/", "'"
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "b"
json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "f"
json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "n"
json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "r"
json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "t"
json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "u"
' Unicode character escape (e.g. \u00a9 = Copyright)
json_Index = json_Index + 1
json_Code = VBA.Mid$(json_String, json_Index, 4)
json_BufferAppend json_buffer, VBA.ChrW(VBA.val("&h" + json_Code)), json_BufferPosition, json_BufferLength
json_Index = json_Index + 4
End Select
Case json_Quote
json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
json_Index = json_Index + 1
Exit Function
Case Else
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
End Select
Loop
End Function
Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
Dim json_Char As String
Dim json_Value As String
json_SkipSpaces json_String, json_Index
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
If VBA.InStr("+-0123456789.eE", json_Char) Then
' Unlikely to have massive number, so use simple append rather than buffer here
json_Value = json_Value & json_Char
json_Index = json_Index + 1
Else
' Excel only stores 15 significant digits, so any numbers larger than that are truncated
' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
' See: http://support.microsoft.com/kb/269370
'
' Fix: Parse -> String, Convert -> String longer than 15 characters containing only numbers and decimal points -> Number
If Not JsonOptions.UseDoubleForLargeNumbers And Len(json_Value) >= 16 Then
json_ParseNumber = json_Value
Else
' VBA.Val does not use regional settings, so guard for comma is not needed
json_ParseNumber = VBA.val(json_Value)
End If
Exit Function
End If
Loop
End Function
Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
' Parse key with single or double quotes
If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then
json_ParseKey = json_ParseString(json_String, json_Index)
ElseIf JsonOptions.AllowUnquotedKeys Then
Dim json_Char As String
Do While json_Index > 0 And json_Index <= Len(json_String)
json_Char = VBA.Mid$(json_String, json_Index, 1)
If (json_Char <> " ") And (json_Char <> ":") Then
json_ParseKey = json_ParseKey & json_Char
json_Index = json_Index + 1
Else
Exit Do
End If
Loop
Else
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''")
End If
' Check for colon and skip if present or throw if not present
json_SkipSpaces json_String, json_Index
If VBA.Mid$(json_String, json_Index, 1) <> ":" Then
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'")
Else
json_Index = json_Index + 1
End If
End Function
Private Function json_Encode(ByVal json_Text As Variant) As String
' Reference: http://www.ietf.org/rfc/rfc4627.txt
' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab
Dim json_Index As Long
Dim json_Char As String
Dim json_AscCode As Long
Dim json_buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
For json_Index = 1 To VBA.Len(json_Text)
json_Char = VBA.Mid$(json_Text, json_Index, 1)
json_AscCode = VBA.AscW(json_Char)
' When AscW returns a negative number, it returns the twos complement form of that number.
' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result.
' https://support.microsoft.com/en-us/kb/272138
If json_AscCode < 0 Then
json_AscCode = json_AscCode + 65536
End If
' From spec, ", \, and control characters must be escaped (solidus is optional)
Select Case json_AscCode
Case 34
' " -> 34 -> \"
json_Char = "\"""
Case 92
' \ -> 92 -> \\
json_Char = "\\"
Case 47
' / -> 47 -> \/ (optional)
If JsonOptions.EscapeSolidus Then
json_Char = "\/"
End If
Case 8
' backspace -> 8 -> \b
json_Char = "\b"
Case 12
' form feed -> 12 -> \f
json_Char = "\f"
Case 10
' line feed -> 10 -> \n
json_Char = "\n"
Case 13
' carriage return -> 13 -> \r
json_Char = "\r"
Case 9
' tab -> 9 -> \t
json_Char = "\t"
Case 0 To 31, 127 To 65535
' Non-ascii characters -> convert to 4-digit hex
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
End Select
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
Next json_Index
json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
End Function
Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef)
json_SkipSpaces json_String, json_Index
json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters)
End Function
Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long)
' Increment index to skip over spaces
Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " "
json_Index = json_Index + 1
Loop
End Sub
Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
' Check if the given string is considered a "large number"
' (See json_ParseNumber)
Dim json_Length As Long
Dim json_CharIndex As Long
json_Length = VBA.Len(json_String)
' Length with be at least 16 characters and assume will be less than 100 characters
If json_Length >= 16 And json_Length <= 100 Then
Dim json_CharCode As String
Dim json_Index As Long
json_StringIsLargeNumber = True
For json_CharIndex = 1 To json_Length
json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1))
Select Case json_CharCode
' Look for .|0-9|E|e
Case 46, 48 To 57, 69, 101
' Continue through characters
Case Else
json_StringIsLargeNumber = False
Exit Function
End Select
Next json_CharIndex
End If
End Function
推荐答案
一种可能的解决方案是创建一个新的Excel工作簿，然后创建所需的工作表/表单/模块/类，并为其指定相同的名称.然后使用ctrl + c/ctrl + v将所有VBA代码从原始工作簿/工作表/表单/模块复制/粘贴到新的新代码中.如果需要，还可以在新工作簿中添加所需的引用.
One possible solution could be to create a new Excel workbook, then create the worksheets/forms/modules/classes you need and give them the same names. Then copy/paste all VBA code from the original workbook/sheets/forms/modules to the new new ones with ctrl+c/ctrl+v. If nessesary, also add the needed references to the new workbook.
准备好后，编译VBA项目并修复可能的剩余错误.保存并关闭所有工作簿和Excel.然后再次打开新工作簿，看看是否有改进.
When you're ready, compile the VBA Project and fix possible remaining errors. Save and close all workbooks and Excel. Then open the new workbook again and see if you experience an improvement.
它肯定帮助了我！！(通过一个自动Excel仪表板，该仪表板包含10000行以上的VBA代码，并连接到SQL Server，从而在不同数据库中读取和写入数千行，并以格式显示在不同的工作表中)
It sure helped me!! (With an automated Excel dashboard wich contains over 10000 lines of VBA code and connects to an SQL Server wich reads and writes over thousands of rows in different databases and displays it in different worksheets with formatting)
使用Excel 2013更新此工作簿时，持续时间不到20秒.在Excel 365中打开后，花费了超过15分钟.创建新工作簿并复制粘贴内容后，花了不到20秒的时间.
With Excel 2013 while updating this workbook it lasted less then 20 seconds. After opening in Excel 365 it took more then 15 minutes. After creating a new workbook and copy paste the contents, it took not more then 20 seconds again.
我希望它也能为您提供帮助！
I hope it can help you too!
这篇关于升级到Office365 ProPlus后，Excel VBA运行极其缓慢的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
