时间戳

首页 > 解决方案 > 使用 VBA 将 Json 解析为 Excel 的最快方法

json - 使用 VBA 将 Json 解析为 Excel 的最快方法

问题描述

我一直在将数据从 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

标签： jsonexcelvba

解决方案

正如已经讨论过的，您的代码之所以慢并不是因为解析 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")
(...)

推荐阅读