Can't fill excel spreadsheet from json using WebHelpers - json

Question

I am having trouble using VBA to fill a table from JSON using WebHelpers. The JSON can be accessed here: http://54.152.85.66:5000/get-product-info. The table is very simple, just six columns and about 8k rows.
Here is the code:
Sub LoadRLSiteData()
Dim helperData As Object
Dim helperDict As Dictionary
Set helperData =
WebHelpers.ParseJson(getXMLPage("http://54.152.85.66:5000/get-product-info"))
Debug.Print "helperData has " & helperData.Count & " items"
' HERE YOU SHOULD LOOP OVER helperData AND PUT INTO SHEET "Helper"
End Sub
Function getXMLPage(link) As String
On Error GoTo recovery
Dim retryCount As Integer
retryCount = 0
Dim ie As MSXML2.XMLHTTP60
Set ie = New MSXML2.XMLHTTP60
the_start:
ie.Open "GET", link, False
ie.setRequestHeader "Content-type", "application/json"
ie.send
While ie.readyState <> 4
DoEvents
Wend
Debug.Print " "
Debug.Print "MSXML HTTP Request to " & link
Debug.Print ie.Status; "XMLHTTP status "; ie.statusText; " at "; Time
getXMLPage = ie.responseText
Exit Function
recovery:
retryCount = retryCount + 1
Debug.Print "Error number: " & Err.Number _
& " " & Err.Description & " Retry " & retryCount
Application.StatusBar = "Error number: " & Err.Number _
& " " & Err.Description & " Retry " & retryCount
If retryCount < 4 Then GoTo the_start Else Exit Function
End Function
Here is what the table should look like:
WebHelpers.ParseJson(getXMLPage("http://54.152.85.66:5000/get-product-info")) returns an object that appears to be a collection of nine dictionaries but I can't seem to unravel how to access the items in the dictionary so I can put them into a sheet.
I modified the code based on QHarr's answer like so:
Option Explicit
Sub LoadRLSiteData()
Dim newHeaders() As Variant
newHeaders = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
GetInfo "Helper Sample", "http://54.152.85.66:5000/get-product-info", newHeaders
newHeaders = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
GetInfo "Images Sample", "http://54.152.85.66:5000/query-missing-images", newHeaders
newHeaders = Array("category", "problem", "url")
GetInfo "Problems Sample", "http://54.152.85.66:5000/get-problems", newHeaders
End Sub
Public Sub GetInfo(mySheet As String, link As String, myHeaders As Variant)
Dim helperData As Object
Dim headers(), item As Object, results(), key As Variant
Dim subItem As Object, r As Long, c As Long, cat As String
Worksheets(mySheet).Activate
Set helperData = WebHelpers.ParseJson(getXMLPage(link))
headers = myHeaders
ReDim results(1 To 100000, 1 To UBound(headers) + 1)
r = 1
Debug.Print "GetInfo unpacking JSON dictionaries"
For Each item In helperData 'col of dict
DoEvents
cat = item("category")
For Each subItem In item("products")
c = 2
results(r, 1) = cat
For Each key In subItem.Keys
results(r, c) = subItem(key)
c = c + 1
Next
r = r + 1
Next
Next
Debug.Print "GetInfo loading values to worksheet"
ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
Debug.Print "GetInfo finished"
End Sub
Function getXMLPage(link) As String
On Error GoTo recovery
Dim retryCount As Integer
retryCount = 0
Dim ie As MSXML2.XMLHTTP60
Set ie = New MSXML2.XMLHTTP60
the_start:
ie.Open "GET", link, False
ie.setRequestHeader "Content-type", "application/json"
ie.send
While ie.readyState <> 4
DoEvents
Wend
Debug.Print " "
Debug.Print "MSXML HTTP Request to " & link
Debug.Print ie.Status; "XMLHTTP status "; ie.statusText; " at "; Time
getXMLPage = ie.responseText
Exit Function
recovery:
retryCount = retryCount + 1
Debug.Print "Error number: " & Err.Number _
& " " & Err.Description & " Retry " & retryCount
Application.StatusBar = "Error number: " & Err.Number _
& " " & Err.Description & " Retry " & retryCount
If retryCount < 4 Then GoTo the_start Else Exit Function
End Function
Except for the third URL ("get-problems"), which has a different schema, this solution works great but it seems like the headers could be extracted from the schema instead of being hardcoded and the same for the variables in the For Each item In helperData loop. This would make the solution cleaner and more generalizable.

Answer 1

I am using a different json parser but this unravels the dictionaries and collections. If installing the code from jsonconverter.bas to your project then go VBE > Tools > References > Add reference to Microsoft Scripting Runtime. You can see how to use from below first End With
The [] are collections looped with For Each and accessed by index; the {} are dictionaries accessed by key.
You can see some of the structure here:
VBA:
Option Explicit
Public Sub GetInfo()
Dim helperData As Object
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://54.152.85.66:5000/get-product-info", False
.send
Set helperData = jsonConverter.ParseJson(.responseText)
End With
Dim headers(), item As Object, results(), key As Variant
Dim subItem As Object, r As Long, c As Long, cat As String
headers = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
ReDim results(1 To 100000, 1 To UBound(headers) + 1)
r = 1
For Each item In helperData 'col of dict
cat = item("category")
For Each subItem In item("products")
c = 2
results(r, 1) = cat
For Each key In subItem.keys
results(r, c) = subItem(key)
c = c + 1
Next
r = r + 1
Next
Next
ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
Sample output:
Integrated with yours I would expect something like:
Option Explicit
Public Sub GetInfo()
Dim helperData As Object
Dim headers(), item As Object, results(), key As Variant
Dim subItem As Object, r As Long, c As Long, cat As String
Set helperData = WebHelpers.ParseJson(getXMLPage("http://54.152.85.66:5000/get-product-info"))
headers = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
ReDim results(1 To 100000, 1 To UBound(headers) + 1)
r = 1
For Each item In helperData 'col of dict
cat = item("category")
For Each subItem In item("products")
c = 2
results(r, 1) = cat
For Each key In subItem.keys
results(r, c) = subItem(key)
c = c + 1
Next
r = r + 1
Next
Next
ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub