将大型集合对象(从json解析)写入excel范围

我正在尝试将json api转换为excel表.我尝试了不同的解析方法,但目前使用的是VBA-JSON(类似于VB-JSON但解析速度更快).到目前为止,我将它转换为Object.如果我是正确的话,这是一个集合.但是,将对象转换为表会花费大量时间.

以下是我的代码.在我正在使用的旧机器上,HTTP>字符串使用9s.解析对象需要花费14s.这些是可以接受的,但是循环在集合中经过一列(25k行)成本为30 + s.我需要大约8列从集合中获取,这将花费太长时间.我的i5机器需要的时间也一样长.

Dim ItemCount As Integer
Dim itemID() As Long

Function httpresp(URL As String) As String
    Dim x As Object: Set x = CreateObject("MSXML2.XMLHTTP")
    x.Open "GET", URL, False
    x.send
    httpresp = x.responseText
End Function

Private Sub btnLoad_Click()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = false

    Dim URL As String: URL = "https://www.gw2shinies.com/api/json/item/tp"
    Dim DecJSON As Object: Set DecJSON = JsonConverter.ParseJson(httpresp(URL))
    ItemCount = DecJSON.Count
    ReDim itemID(1 To ItemCount)
    Range("A2:S25000").Clear                'clear range
    For i = 1 To ItemCount
        Cells(i + 1, 1).Value = DecJSON(i)("item_id")
    Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

无论如何我可以从庞大的集合对象中更快地填充excel表吗？

我还检查了Rest to Excel库,但是经过几个小时的学习后我都无法理解......加上我不知道即使我让它工作,它会如何表现.

考虑下面的例子,有纯VBA JSON解析器.它非常快,但不是那么灵活,因此它适用于解析仅包含类似数据的对象的简单json数组.

Option Explicit

Sub Test()

    Dim strJsonString As String
    Dim arrResult() As Variant

    ' download
    strJsonString = DownloadJson("https://www.gw2shinies.com/api/json/item/tp")

    ' process
    arrResult = ConvertJsonToArray(strJsonString)

    ' output
    Output Sheets(1), arrResult

End Sub

Function DownloadJson(strUrl As String) As String

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", strUrl
        .Send
        If .Status <> 200 Then
            Debug.Print .Status
            Exit Function
        End If
        DownloadJson = .responseText
    End With

End Function


Function ConvertJsonToArray(strJsonString As String) As Variant

    Dim strCnt As String
    Dim strMarkerQuot As String
    Dim arrUnicode() As String
    Dim arrQuots() As String
    Dim arrRows() As String
    Dim arrProps() As String
    Dim arrTokens() As String
    Dim arrHeader() As String
    Dim arrColumns() As Variant
    Dim arrColumn() As Variant
    Dim arrTable() As Variant
    Dim j As Long
    Dim i As Long
    Dim lngMaxRowIdx As Long
    Dim lngMaxColIdx As Long
    Dim lngPrevIdx As Long
    Dim lngFoundIdx As Long
    Dim arrProperty() As String
    Dim strPropName As String
    Dim strPropValue As String

    strCnt = Split(strJsonString, "[{")(1)
    strCnt = Split(strCnt, "}]")(0)

    strMarkerQuot = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
    strCnt = Replace(strCnt, "\\", "\")
    strCnt = Replace(strCnt, "\""", strMarkerQuot)
    strCnt = Replace(strCnt, "\/", "/")
    strCnt = Replace(strCnt, "\b", Chr(8))
    strCnt = Replace(strCnt, "\f", Chr(12))
    strCnt = Replace(strCnt, "\n", vbLf)
    strCnt = Replace(strCnt, "\r", vbCr)
    strCnt = Replace(strCnt, "\t", vbTab)

    arrUnicode = Split(strCnt, "\u")
    For i = 1 To UBound(arrUnicode)
        arrUnicode(i) = ChrW(CLng("&H" & Left(arrUnicode(i), 4))) & Mid(arrUnicode(i), 5)
    Next
    strCnt = Join(arrUnicode, "")

    arrQuots = Split(strCnt, """")
    ReDim arrTokens(UBound(arrQuots) \ 2)
    For i = 1 To UBound(arrQuots) Step 2
        arrTokens(i \ 2) = Replace(arrQuots(i), strMarkerQuot, """")
        arrQuots(i) = "%" & i \ 2
    Next

    strCnt = Join(arrQuots, "")
    strCnt = Replace(strCnt, " ", "")

    arrRows = Split(strCnt, "},{")
    lngMaxRowIdx = UBound(arrRows)
    For j = 0 To lngMaxRowIdx
        lngPrevIdx = -1
        arrProps = Split(arrRows(j), ",")
        For i = 0 To UBound(arrProps)
            arrProperty = Split(arrProps(i), ":")
            strPropName = arrProperty(0)
            If Left(strPropName, 1) = "%" Then strPropName = arrTokens(Mid(strPropName, 2))
            lngFoundIdx = GetArrayItemIndex(arrHeader, strPropName)
            If lngFoundIdx = -1 Then
                ReDim arrColumn(lngMaxRowIdx)
                If lngPrevIdx = -1 Then
                    ArrayAddItem arrHeader, strPropName
                    lngPrevIdx = UBound(arrHeader)
                    ArrayAddItem arrColumns, arrColumn
                Else
                    lngPrevIdx = lngPrevIdx + 1
                    ArrayInsertItem arrHeader, lngPrevIdx, strPropName
                    ArrayInsertItem arrColumns, lngPrevIdx, arrColumn
                End If
            Else
                lngPrevIdx = lngFoundIdx
            End If
            strPropValue = arrProperty(1)
            If Left(strPropValue, 1) = "%" Then strPropValue = arrTokens(Mid(strPropValue, 2))
            arrColumns(lngPrevIdx)(j) = strPropValue
        Next
    Next
    lngMaxColIdx = UBound(arrHeader)
    ReDim arrTable(lngMaxRowIdx + 1, lngMaxColIdx)
    For i = 0 To lngMaxColIdx
        arrTable(0, i) = arrHeader(i)
    Next
    For j = 0 To lngMaxRowIdx
        For i = 0 To lngMaxColIdx
            arrTable(j + 1, i) = arrColumns(i)(j)
        Next
    Next

    ConvertJsonToArray = arrTable

End Function

Sub Output(objSheet As Worksheet, arrCells() As Variant)

    With objSheet
        .Select
        .Range(.Cells(1, 1), Cells(UBound(arrCells, 1) + 1, UBound(arrCells, 2) + 1)).Value = arrCells
        .Columns.AutoFit
    End With
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
        .FreezePanes = True
    End With

End Sub

Function GetArrayItemIndex(arrElements, varTest)
    For GetArrayItemIndex = 0 To SafeUBound(arrElements)
        If arrElements(GetArrayItemIndex) = varTest Then Exit Function
    Next
    GetArrayItemIndex = -1
End Function

Sub ArrayAddItem(arrElements, varElement)
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    arrElements(UBound(arrElements)) = varElement
End Sub

Sub ArrayInsertItem(arrElements, lngIndex, varElement)
    Dim i As Long
    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)
    For i = UBound(arrElements) To lngIndex + 1 Step -1
        arrElements(i) = arrElements(i - 1)
    Next
    arrElements(i) = varElement
End Sub

Function SafeUBound(arrTest)
    On Error Resume Next
    SafeUBound = -1
    SafeUBound = UBound(arrTest)
End Function

downolad(约7 MB)需要大约5秒,处理需要10秒,输出需要1.5秒.生成的工作表包含23694行,包括表头: