Write large collection object (parsed from json) t

问题:

I am trying to convert a json api to excel table. I tried different parsing methods but currently using VBA-JSON (similar to VB-JSON but faster parsing). So far I got it to convert into a Object. It is a collection if I'm correct. However to convert the object into a table costs a huge amount of time.

The following is my code. On this old machine I'm using, the HTTP > string uses 9s. Parsing into the object costs 14s. These are acceptable but the for loop to go through one column (25k rows) in the collection costs 30+s. I need around 8 columns to get from the collection and that would take way too long. And it takes just as long in my i5 machine.

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

Is there anyway I can populate the excel table faster from the huge collection object?

I also checked Rest to Excel library but I fail to understand it after studying for hours......plus I don't know even if I get it to work, how would it perform.

回答1:

Consider the below example, there is pure VBA JSON parser. It's quite fast, but not so flexible, so it's suitable for parsing of simple json array of objects containing table-like data only.

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

It takes about 5 secs for downolad (approx. 7 MB), 10 secs for processing and 1.5 for output for me. The resulting worksheet contains 23694 rows including table header:

回答2:

Have you tried calling the web service via the vba-web toolkit (from the same people who made vba-json)? It automatically wraps the JSON result into a data object.

I then created a Function that converts a simple table-like JSON into a 2D array, which I then paste it into a Range.

First, here's the function you can add to your code:

' Converts a simple JSON dictionary into an array
Function ConvertSimpleJsonToArray(data As Variant, ParamArray columnDefinitionsArray() As Variant) As Variant
    Dim NumRows, NumColumns As Long
    NumRows = data.Count
    NumColumns = UBound(columnDefinitionsArray) - LBound(columnDefinitionsArray) + 1

    Dim ResultArray() As Variant
    ReDim ResultArray(0 To NumRows, 0 To (NumColumns - 1)) 'Rows need an extra header row but columns do not

    Dim x, y As Integer

    'Column headers
    For y = LBound(columnDefinitionsArray) To UBound(columnDefinitionsArray)
        ResultArray(LBound(ResultArray), y) = columnDefinitionsArray(y)
    Next

    'Data rows
    For x = 1 To NumRows
        For y = LBound(columnDefinitionsArray) To UBound(columnDefinitionsArray)
            ResultArray(x, y) = data(x)(columnDefinitionsArray(y))
        Next
    Next

    ConvertSimpleJsonToArray = ResultArray
End Function

Here's how I tried calling your API and populating just 4 columns into Excel:

Sub Auto_Open()
    Dim FocusClient As New WebClient
    FocusClient.BaseUrl = "https://www.gw2shinies.com/api"

    ' Use GetJSON helper to execute simple request and work with response
    Dim Resource As String
    Dim Response As WebResponse

    'Create a Request and get Response
    Resource = "json/item/tp"
    Set Response = FocusClient.GetJson(Resource)

    If Response.StatusCode = WebStatusCode.Ok Then
        Dim ResultArray() As Variant

        ResultArray = ConvertSimpleJsonToArray(Response.data, "item_id", "name", "type", "subtype")

        Dim NumRows, NumColumns As Long
        NumRows = UBound(ResultArray) - LBound(ResultArray) + 1
        NumColumns = UBound(ResultArray, 2) - LBound(ResultArray, 2) + 1

        ActiveSheet.Range("a1").Resize(NumRows, NumColumns).Value = ResultArray
    Else
        Debug.Print "Error: " & Response.Content
    End If
End Sub

Yes it does take a few seconds to run, but that's more likely to the 26000 rows you have. Even loading the raw JSON in Chrome took a few seconds and this has JSON parsing and loading into array on top of it. You can benchmark the code by Debug.Print timestamps after each code block.

I hope that helps!

回答3:

It is faster to write all of the values at once then to do it cell by cell. Also you may have secondary event firing so disabling events may help with performance. If performance is still poor with the below code the problem is with the performance of JsonConverter.

Dim ItemCount As Integer
Dim items() As Variant

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
    Application.EnableEvents = 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 items(1 To ItemCount, 1 To 1)
    Range("A2:S25000").Clear                'clear range
    Dim test As Variant
    For i = 1 To ItemCount
        items(i, 1) = DecJSON(i)("item_id")
        'Cells(i + 1, 1).Value = DecJSON(i)("item_id")
    Next i
    Range(Range("A2"), Range("A2").Offset(ItemCount)).Value = items

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub