1

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
Improve this question
13
  • Did you time and pinpoint where the bottleneck is? Is it the request, parsing or writing to worksheet? Also this looks more suitable for CodeReview. Commented Aug 11, 2021 at 7:18
  • 1
    This code works, so is better posted on the CodeReview Stack. Commented Aug 11, 2021 at 7:24
  • 1
    So, the problem is not parsing the JSON response as implied by the title, but writing to the sheet...? Commented Aug 11, 2021 at 7:34
  • 1
    You can make an array and populate it with the data then write once into the sheet for each continuous range. What you are doing now is writing 23 times per row, multiply that with 5k rows of data = 115k times! Commented Aug 11, 2021 at 7:43
  • 1
    @Arham There are plenty of resources on the topic of Array, you have to read and practice them if you want to improve. Commented Aug 11, 2021 at 8:47

2 Answers 2

Reset to default
2

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")
(...)
Improve this answer
Sign up to request clarification or add additional context in comments.

2 Comments

Sorry for being late reply. Thank you very much its working great @FunThomas
There is one problem whenever i open the file and runs the code it takes approx. 40 to 55 seconds to paste the data but when i again run it process data within 10 seconds. Same issue is with other solution. This is causing because of API late Response.
1

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
Improve this answer

10 Comments

Sorry for being late reply. This seems to be very great thank you very much @Raymond Wu can you please share that how to know the Column reference >
I got it Thank you once again @Raymond Wu
There is one problem whenever i open the file and runs the code it takes approx. 40 to 55 seconds to paste the data but when i again run it process data within 10 seconds. Same issue is with other solution. This is causing because of API late Response.
@Arham Nothing much we can do about that since it's dependent on the API server that is not in our control.
@Arham link is broken. Post a new question if you want since it is out of scope of this question
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.