使用 VBA 将 Json 解析为 Excel 的最快方法答案

【问题标题】：Fastest way of Parsing Json to Excel using VBA使用 VBA 将 Json 解析为 Excel 的最快方法
【发布时间】：2021-08-11 07:12:56
【问题描述】：

我一直在将数据从 JSON 解析到 Excel，代码运行良好，但写入数据需要很长时间，超过 1 分钟。

每列有 5K 行数据。我一直在寻找以更少的时间将数据解析为 excel 的更好方法，但没有成功。

我确实希望有办法实现这一目标。任何帮助将不胜感激

Sub parsejson()

Dim t As Single
t = Timer
Dim objRequest      As Object
    Dim strUrl      As String
    Dim blnAsync    As Boolean
    Dim strResponse As String
    Dim idno, r     As Long
    Dim ws, ws2    As Worksheet
    Dim JSON        As Object
    Dim lrow As Long
    
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
    
    Set ws = Sheet1
    Set ws2 = Sheet2
    
    Set objRequest = CreateObject("MSXML2.XMLHTTP")
    strUrl = ""
    blnAsync = True
    
    With objRequest
        .Open "GET", strUrl, blnAsync
        .setRequestHeader "Content-Type", "application/json"
        .send
        
        While objRequest.readyState <> 4
            DoEvents
        Wend
      
    strResponse = .ResponseText
    End With
    
    Dim resultDict As Object
    Set resultDict = ParseJson("{""result"":" & strResponse & "}")
    
    Dim i As Long
    Dim resultNum As Long
    resultNum = resultDict("result").Count
    r = 2
    For i = 1 To resultNum
 
        ws.Cells(r, "B").Value = resultDict("result")(i)("productName")
        ws.Cells(r, "C").Value = resultDict("result")(i)("upc")
        ws.Cells(r, "D").Value = resultDict("result")(i)("asin")
        ws.Cells(r, "E").Value = resultDict("result")(i)("epid")
        ws.Cells(r, "G").Value = resultDict("result")(i)("platform")
        ws.Cells(r, "I").Value = resultDict("result")(i)("uniqueID")
        ws.Cells(r, "L").Value = resultDict("result")(i)("productShortName")
        ws.Cells(r, "M").Value = resultDict("result")(i)("coverPicture")
        ws.Cells(r, "N").Value = resultDict("result")(i)("realeaseYear")
        ws.Cells(r, "Q").Value = resultDict("result")(i)("verified")
        ws.Cells(r, "S").Value = resultDict("result")(i)("category")
        ws2.Cells(r, "E").Value = resultDict("result")(i)("brand")
        ws2.Cells(r, "F").Value = resultDict("result")(i)("compatibleProduct")
        ws2.Cells(r, "G").Value = resultDict("result")(i)("type")
        ws2.Cells(r, "H").Value = resultDict("result")(i)("connectivity")
        ws2.Cells(r, "I").Value = resultDict("result")(i)("compatibleModel")
        ws2.Cells(r, "J").Value = resultDict("result")(i)("color")
        ws2.Cells(r, "K").Value = resultDict("result")(i)("material")
        ws2.Cells(r, "L").Value = resultDict("result")(i)("cableLength")
        ws2.Cells(r, "M").Value = resultDict("result")(i)("mpn")
        ws2.Cells(r, "O").Value = resultDict("result")(i)("features")
        ws2.Cells(r, "Q").Value = resultDict("result")(i)("wirelessRange")
        ws2.Cells(r, "T").Value = resultDict("result")(i)("bundleDescription")

        r = r + 1
    Next i
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
    
    MsgBox "RunTime : " & Format((Timer - t) / 86400, "hh:mm:ss")

End Sub

【问题讨论】：

您是否有时间确定瓶颈在哪里？是请求、解析还是写入工作表？这看起来更适合 CodeReview。
此代码有效，因此最好发布在 CodeReview 堆栈上。
所以，问题不在于标题所暗示的解析 JSON 响应，而是写入工作表...？
您可以创建一个数组并用数据填充它，然后在 each 连续范围的工作表中写入一次。您现在所做的是每行写入 23 次，乘以 5k 行数据 = 115k 次！
@Arham 有很多关于 Array 主题的资源，如果你想提高，你必须阅读和实践它们。

标签： json excel vba

【解决方案1】：

正如已经讨论过的，您的代码之所以慢并不是因为解析 JSON，而是因为您逐个单元格地编写每个值。与在内存中完成的事情相比，VBA 和 Excel 之间的接口速度较慢，因此要采取的方法是将数据写入一个二维数组，该数组可以一次全部写入 Excel。

由于 Excel 中的目标不是单个范围，我建议有一个小例程来收集和写入一列的数据。如果列或字段名称发生变化，则易于理解和适应。

Sub writeColumn(destRange As Range, resultDict As Object, colName As String)    
    Dim resultNum As Long, i As Long
    resultNum = resultDict("result").Count
    ' Build a 2-dimesional array. 2nd index is always 1 as we write only one column.
    ReDim columnData(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        columnData(i, 1) = resultDict("result")(i)(colName)
    Next
    ' Write the data into the column
    destRange.Cells(1, 1).Resize(resultNum, 1) = columnData
End Sub

对于每个字段/列，您需要在主程序中调用（但没有任何循环）

Call writeColumn(ws.Cells(r, "B"), resultDict, "productName")
(...)
Call writeColumn(ws2.Cells(r, "E"), resultDict, "brand")
(...)

【讨论】：

抱歉回复晚了。非常感谢它工作得很好@FunThomas
每当我打开文件并运行代码时，都会出现一个问题，大约需要 10 分钟。粘贴数据需要 40 到 55 秒，但是当我再次运行它时，它会在 10 秒内处理数据。其他解决方案也有同样的问题。这是由于 API 延迟响应造成的。

【解决方案2】：

向/从单元格写入/读取值是一项非常缓慢的操作，当您连续多次执行此操作时更是如此，因此将数据填充到数组中并以块的形式写入单元格是最好的方法。

由于您的要求涉及多个连续范围，因此您必须多次写入工作表。

用下面的代码替换你的整个 For 循环，不是最漂亮但应该可以工作：

Dim dataArr() As Variant
    ReDim dataArr(1 To resultNum, 1 To 4) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("productName")
        dataArr(i, 2) = resultDict("result")(i)("upc")
        dataArr(i, 3) = resultDict("result")(i)("asin")
        dataArr(i, 4) = resultDict("result")(i)("epid")
    Next i
    ws.Range(ws.Cells(2, "B"), ws.Cells(1 + resultNum, "E")).Value = dataArr
                
    ReDim dataArr(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("platform")
    Next i
    ws.Range(ws.Cells(2, "G"), ws.Cells(1 + resultNum, "G")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("uniqueID")
    Next i
    ws.Range(ws.Cells(2, "I"), ws.Cells(1 + resultNum, "I")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 3) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("productShortName")
        dataArr(i, 2) = resultDict("result")(i)("coverPicture")
        dataArr(i, 3) = resultDict("result")(i)("realeaseYear")
    Next i
    ws.Range(ws.Cells(2, "L"), ws.Cells(1 + resultNum, "N")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("verified")
    Next i
    ws.Range(ws.Cells(2, "Q"), ws.Cells(1 + resultNum, "Q")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("category")
    Next i
    ws.Range(ws.Cells(2, "S"), ws.Cells(1 + resultNum, "S")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 9) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("brand")
        dataArr(i, 2) = resultDict("result")(i)("compatibleProduct")
        dataArr(i, 3) = resultDict("result")(i)("type")
        dataArr(i, 4) = resultDict("result")(i)("connectivity")
        dataArr(i, 5) = resultDict("result")(i)("compatibleModel")
        dataArr(i, 6) = resultDict("result")(i)("color")
        dataArr(i, 7) = resultDict("result")(i)("material")
        dataArr(i, 8) = resultDict("result")(i)("cableLength")
        dataArr(i, 9) = resultDict("result")(i)("mpn")
    Next i
    ws2.Range(ws2.Cells(2, "E"), ws2.Cells(1 + resultNum, "M")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 2) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("features")
        dataArr(i, 2) = resultDict("result")(i)("wirelessRange")
    Next i
    ws2.Range(ws2.Cells(2, "O"), ws2.Cells(1 + resultNum, "Q")).Value = dataArr
    
    ReDim dataArr(1 To resultNum, 1 To 1) As Variant
    For i = 1 To resultNum
        dataArr(i, 1) = resultDict("result")(i)("bundleDescription")
    Next i
    ws2.Range(ws2.Cells(2, "T"), ws2.Cells(1 + resultNum, "T")).Value = dataArr

【讨论】：

抱歉回复晚了。这似乎非常棒，非常感谢@Raymond Wu，你能分享一下如何知道专栏参考>
我明白了，再次感谢@Raymond Wu
每当我打开文件并运行代码时，都会出现一个问题，大约需要 10 分钟。粘贴数据需要 40 到 55 秒，但是当我再次运行它时，它会在 10 秒内处理数据。其他解决方案也有同样的问题。这是由于 API 延迟响应造成的。
@Arham 对此我们无能为力，因为它依赖于不受我们控制的 API 服务器。
@Arham 链接已损坏。如果您愿意，可以发布一个新问题，因为它超出了此问题的范围