Fastest way of Parsing Json to Excel using VBA

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