Write large collection object (parsed from json) to excel range

Question

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

Answer 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:

Update

Fast jsJsonParser may help to process large amount of data. Check this Douglas Crockford json2.js implementation for VBA