Fastest way of Parsing Json to Excel using VBA - json

Question

I have been parsing data from JSON to Excel and the code is working fine but it takes much time to write data which is more than 1 minute.
Every Column has 5K rows of data. I have searched to find better way of parsing data into excel with less time but no success.
I do hope there will be an way of achieving this. Any help will be much appreciated
Sub parsejson()
Dim t As Single
t = Timer
Dim objRequest As Object
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim idno, r As Long
Dim ws, ws2 As Worksheet
Dim JSON As Object
Dim lrow As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Set ws = Sheet1
Set ws2 = Sheet2
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = ""
blnAsync = True
With objRequest
.Open "GET", strUrl, blnAsync
.setRequestHeader "Content-Type", "application/json"
.send
While objRequest.readyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Dim resultDict As Object
Set resultDict = ParseJson("{""result"":" & strResponse & "}")
Dim i As Long
Dim resultNum As Long
resultNum = resultDict("result").Count
r = 2
For i = 1 To resultNum
ws.Cells(r, "B").Value = resultDict("result")(i)("productName")
ws.Cells(r, "C").Value = resultDict("result")(i)("upc")
ws.Cells(r, "D").Value = resultDict("result")(i)("asin")
ws.Cells(r, "E").Value = resultDict("result")(i)("epid")
ws.Cells(r, "G").Value = resultDict("result")(i)("platform")
ws.Cells(r, "I").Value = resultDict("result")(i)("uniqueID")
ws.Cells(r, "L").Value = resultDict("result")(i)("productShortName")
ws.Cells(r, "M").Value = resultDict("result")(i)("coverPicture")
ws.Cells(r, "N").Value = resultDict("result")(i)("realeaseYear")
ws.Cells(r, "Q").Value = resultDict("result")(i)("verified")
ws.Cells(r, "S").Value = resultDict("result")(i)("category")
ws2.Cells(r, "E").Value = resultDict("result")(i)("brand")
ws2.Cells(r, "F").Value = resultDict("result")(i)("compatibleProduct")
ws2.Cells(r, "G").Value = resultDict("result")(i)("type")
ws2.Cells(r, "H").Value = resultDict("result")(i)("connectivity")
ws2.Cells(r, "I").Value = resultDict("result")(i)("compatibleModel")
ws2.Cells(r, "J").Value = resultDict("result")(i)("color")
ws2.Cells(r, "K").Value = resultDict("result")(i)("material")
ws2.Cells(r, "L").Value = resultDict("result")(i)("cableLength")
ws2.Cells(r, "M").Value = resultDict("result")(i)("mpn")
ws2.Cells(r, "O").Value = resultDict("result")(i)("features")
ws2.Cells(r, "Q").Value = resultDict("result")(i)("wirelessRange")
ws2.Cells(r, "T").Value = resultDict("result")(i)("bundleDescription")
r = r + 1
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
MsgBox "RunTime : " & Format((Timer - t) / 86400, "hh:mm:ss")
End Sub

Answer 1

As already discussed, your code is not slow because of parsing the JSON, but because you write every value cell by cell. The interface between VBA and Excel is slow compared to things done in memory, so the way to go is to write the data into a 2-dimensional array that can be written all at once into Excel.
As the destination in Excel is not a single Range, I suggest to have a small routine that collects and writes data for one column. Easy to understand and easy to adapt if columns or field names changes.
Sub writeColumn(destRange As Range, resultDict As Object, colName As String)
Dim resultNum As Long, i As Long
resultNum = resultDict("result").Count
' Build a 2-dimesional array. 2nd index is always 1 as we write only one column.
ReDim columnData(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
columnData(i, 1) = resultDict("result")(i)(colName)
Next
' Write the data into the column
destRange.Cells(1, 1).Resize(resultNum, 1) = columnData
End Sub
For every field/column, you need a call in your main routine (but without any loop)
Call writeColumn(ws.Cells(r, "B"), resultDict, "productName")
(...)
Call writeColumn(ws2.Cells(r, "E"), resultDict, "brand")
(...)

Answer 2

Writing/Reading value to/from cell is a very slow operation, even more so when you are doing that so many times in a row therefore populating your data in an array and write into the cells in blocks is the best way.
Since your requirement involves multiple continuous range, you will have to write into the sheet multiple times.
Replace your entire For loop with the below code, not the prettiest but should work:
Dim dataArr() As Variant
ReDim dataArr(1 To resultNum, 1 To 4) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("productName")
dataArr(i, 2) = resultDict("result")(i)("upc")
dataArr(i, 3) = resultDict("result")(i)("asin")
dataArr(i, 4) = resultDict("result")(i)("epid")
Next i
ws.Range(ws.Cells(2, "B"), ws.Cells(1 + resultNum, "E")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("platform")
Next i
ws.Range(ws.Cells(2, "G"), ws.Cells(1 + resultNum, "G")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("uniqueID")
Next i
ws.Range(ws.Cells(2, "I"), ws.Cells(1 + resultNum, "I")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 3) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("productShortName")
dataArr(i, 2) = resultDict("result")(i)("coverPicture")
dataArr(i, 3) = resultDict("result")(i)("realeaseYear")
Next i
ws.Range(ws.Cells(2, "L"), ws.Cells(1 + resultNum, "N")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("verified")
Next i
ws.Range(ws.Cells(2, "Q"), ws.Cells(1 + resultNum, "Q")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("category")
Next i
ws.Range(ws.Cells(2, "S"), ws.Cells(1 + resultNum, "S")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 9) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("brand")
dataArr(i, 2) = resultDict("result")(i)("compatibleProduct")
dataArr(i, 3) = resultDict("result")(i)("type")
dataArr(i, 4) = resultDict("result")(i)("connectivity")
dataArr(i, 5) = resultDict("result")(i)("compatibleModel")
dataArr(i, 6) = resultDict("result")(i)("color")
dataArr(i, 7) = resultDict("result")(i)("material")
dataArr(i, 8) = resultDict("result")(i)("cableLength")
dataArr(i, 9) = resultDict("result")(i)("mpn")
Next i
ws2.Range(ws2.Cells(2, "E"), ws2.Cells(1 + resultNum, "M")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 2) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("features")
dataArr(i, 2) = resultDict("result")(i)("wirelessRange")
Next i
ws2.Range(ws2.Cells(2, "O"), ws2.Cells(1 + resultNum, "Q")).Value = dataArr
ReDim dataArr(1 To resultNum, 1 To 1) As Variant
For i = 1 To resultNum
dataArr(i, 1) = resultDict("result")(i)("bundleDescription")
Next i
ws2.Range(ws2.Cells(2, "T"), ws2.Cells(1 + resultNum, "T")).Value = dataArr