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

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 ExplicitSub 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 SubFunction 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 FunctionFunction 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 FunctionSub 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 SubFunction GetArrayItemIndex(arrElements, varTest)    For GetArrayItemIndex = 0 To SafeUBound(arrElements)        If arrElements(GetArrayItemIndex) = varTest Then Exit Function    Next    GetArrayItemIndex = -1End FunctionSub ArrayAddItem(arrElements, varElement)    ReDim Preserve arrElements(SafeUBound(arrElements) + 1)    arrElements(UBound(arrElements)) = varElementEnd SubSub 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) = varElementEnd SubFunction 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

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 arrayFunction 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 = ResultArrayEnd 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 IfEnd 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!

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 IntegerDim items() As VariantFunction httpresp(URL As String) As String    Dim x As Object: Set x = CreateObject("MSXML2.XMLHTTP")    x.Open "GET", URL, False    x.send    httpresp = x.responseTextEnd FunctionPrivate 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 = TrueEnd Sub