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

Question

I am trying to convert json api to excel table. I tried different parsing methods, but currently using VBA-JSON (similar to VB-JSON, but parsing faster). So far, I got it to convert to an object. This is a compilation if I am right. However, it takes a huge amount of time to convert an object to a table.

Below is my code. On this old machine that I'm using, the HTTP> line uses 9s. Analysis of the object costs 14 seconds. They are acceptable, but the for loop to go through one column (25 thousand rows) in the collection is 30 + s. I need about 8 columns to get from the collection, and it takes too much time. And it will take the same amount of time on 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 

Anyway, can I populate an excel table from a huge collection object faster?

I also checked Rest to Excel library , but I do not understand it after studying for several hours ...... plus I do not know, even if I earn it, how would this happen.

Answer 1

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

 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 seconds for downolad (about 7 MB), 10 seconds for processing and 1.5 for output for me. The resulting worksheet contains 23694 rows, including the table heading:

Answer 2

Have you tried using the web service using the vba-web toolkit (from the same people who did vba-json)? It automatically transfers the JSON result to the data object.

Then I created a function that converts a simple table JSON into a 2D array, which I then insert it into a range.

Firstly, here is a function that 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 

This is how I tried to call your API and populated just four columns in 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 will take a few seconds, but it is more likely for the 26,000 lines that you have. Even loading raw JSON into Chrome took a few seconds, and that is JSON parsing and loading into an array on top of it. You can compare the code using Debug.Print timestamps after each block of code.

I hope this helps!

Answer 3

It’s faster to write all the values ​​at once, and then do it cell by cell. In addition, you may have triggered secondary events, so disabling events can help in performance. If the performance is still unsatisfactory when using the code below, 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