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 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
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!