[英]Excel VBA running extremely slow after upgraded to Office365 ProPlus
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.此代码用于解析从 HTTP 请求中获取的 JSON 字符串,根本没有工作表/工作簿操作。 Before office upgraded to office365 ProPlus, it's quite efficient.在office升级到office365 ProPlus之前,还是挺有效率的。 But after upgrade, a json which could be parsed less than 2 seconds, costs several minutes.但是升级后,一个不到2秒就可以解析出来的json,要花费几分钟的时间。 Personally I don't understand the root cause.我个人不明白根本原因。
Code source: @Tim Hall https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas代码来源:@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
I had the same issue.我遇到过同样的问题。 Upgrade of JsonConverter module did help to me. JsonConverter 模块的升级对我有帮助。 https://github.com/VBA-tools/VBA-JSON/releases/tag/v2.3.0 . https://github.com/VBA-tools/VBA-JSON/releases/tag/v2.3.0 。
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.一种可能的解决方案是创建一个新的 Excel 工作簿,然后创建您需要的工作表/表单/模块/类并为它们指定相同的名称。 Then copy/paste all VBA code from the original workbook/sheets/forms/modules to the new new ones with ctrl+c/ctrl+v.然后使用 ctrl+c/ctrl+v 将原始工作簿/工作表/表单/模块中的所有 VBA 代码复制/粘贴到新的新代码中。 If nessesary, also add the needed references to the new workbook.如果需要,还可以将所需的引用添加到新工作簿中。
When you're ready, compile the VBA Project and fix possible remaining errors.准备就绪后,编译 VBA 项目并修复可能存在的剩余错误。 Save and close all workbooks and Excel.保存并关闭所有工作簿和 Excel。 Then open the new workbook again and see if you experience an improvement.然后再次打开新工作簿,看看是否有改进。
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) (使用包含超过 10000 行 VBA 代码并连接到 SQL Server 的自动化 Excel 仪表板,该 SQL Server 可在不同数据库中读取和写入数千行,并将其显示在不同的工作表中并带有格式)
With Excel 2013 while updating this workbook it lasted less then 20 seconds.使用 Excel 2013 更新此工作簿时,它持续了不到 20 秒。 After opening in Excel 365 it took more then 15 minutes.在 Excel 365 中打开后,花了超过 15 分钟。 After creating a new workbook and copy paste the contents, it took not more then 20 seconds again.创建新工作簿并复制粘贴内容后,再次花费了不到 20 秒的时间。
I hope it can help you too!我也希望它能帮到你!
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.