It's nice to pop onto my own blog and take some working code and re-apply it for a current problem. My JSON parsing posts are quite popular. In this instance I wanted to download and parse JSON data from the United Kingdom Parliamentary Petitions website.
The petition data gives two drill downs: (i) signature count by region and (ii) signature count by constituency.
The clever JSON parsing code is given to us by Douglas Crockford from his github site, you can see it being downloaded in the function SC (stands for Script Control).
Parsing returns a JSON object that is scriptable from VBA upon which we use VBA.CallByName(jsonObject, <property name>, VbGet) to drill down through the tree nodes.
If the scriptable JSON object is an array that it will support VBA's For Each .. Next syntax and so looping through is a breeze.
All the remaining code is simply plain vanilla that pastes the results on to the worksheet.
Don't forget to go to Tools->References and add the dependencies listed in the top comments or it will not compile. Also the code expects a worksheet with two sheets with codenames Sheet1 and Sheet2.
Enjoy!
Option Explicit
'* Tools->References
' MSScriptControl Microsoft Script Control 1.0 C:\Windows\SysWOW64\msscript.ocx
' MSXML2 Microsoft XML, v6.0 C:\Windows\SysWOW64\msxml6.dll
Private Enum enuConstituencyColumns
eCCMP = 0
eCCName
eCCONSCode
eCCCountry
eCCSigCount
eCCFirst = eCCMP
eCCLast = eCCSigCount
End Enum
Private Enum enuRegionColumns
eRCName = 0
eRCONSCode
eRCSigCount
eRCFirst = eRCName
eRCLast = eRCSigCount
End Enum
Private Const clConsituencyCount As Long = 650
Private Const clRegionCount As Long = 12
Private Sub TestGetPetitionData()
Const cl_petition_endchildfoodpoverty As Long = 554276 'no child should be going hungry #endchildfoodpoverty
GetPetitionData cl_petition_endchildfoodpoverty
End Sub
Private Sub GetPetitionData(ByVal lPetitionNumber As Long)
Dim sPetitionJSON As String
sPetitionJSON = RunHttpRequest("https://petition.parliament.uk/petitions/" & lPetitionNumber & ".json")
Dim oSC As ScriptControl
Set oSC = SC
'Stop
Dim objSafelyParsed As Object
Set objSafelyParsed = SC.Run("JSON_parse", sPetitionJSON)
Dim objDataAttributes As Object
Set objDataAttributes = VBA.CallByName(VBA.CallByName(objSafelyParsed, "data", VbGet), "attributes", VbGet)
'********** do the constituencies ***********
Dim objConstituencySignatures As Object
Set objConstituencySignatures = VBA.CallByName(objDataAttributes, "signatures_by_constituency", VbGet)
Dim vConstituencies(0 To clConsituencyCount - 1, eCCFirst To eCCLast) As Variant
Dim objConstituencyLoop As Object
Dim idxConstituencyLoop As Long: idxConstituencyLoop = 0
For Each objConstituencyLoop In objConstituencySignatures
vConstituencies(idxConstituencyLoop, eCCMP) = CallByName(objConstituencyLoop, "mp", VbGet)
vConstituencies(idxConstituencyLoop, eCCName) = CallByName(objConstituencyLoop, "name", VbGet)
Dim sONSCode As String
sONSCode = CallByName(objConstituencyLoop, "ons_code", VbGet)
vConstituencies(idxConstituencyLoop, eCCONSCode) = sONSCode
vConstituencies(idxConstituencyLoop, eCCCountry) = Left$(sONSCode, 1)
vConstituencies(idxConstituencyLoop, eCCSigCount) = CallByName(objConstituencyLoop, "signature_count", VbGet)
'Stop
idxConstituencyLoop = idxConstituencyLoop + 1
Next
Sheet1.Cells.Clear
WriteConstituencies Sheet1, vConstituencies
'********** do the regions ***********
Dim objRegionSignatures As Object
Set objRegionSignatures = VBA.CallByName(objDataAttributes, "signatures_by_region", VbGet)
Dim vRegions(0 To clRegionCount - 1, eRCFirst To eRCLast) As Variant
Dim objRegionLoop As Object
Dim idxRegionLoop As Long: idxRegionLoop = 0
For Each objRegionLoop In objRegionSignatures
vRegions(idxRegionLoop, eRCName) = CallByName(objRegionLoop, "name", VbGet)
vRegions(idxRegionLoop, eRCONSCode) = CallByName(objRegionLoop, "ons_code", VbGet)
vRegions(idxRegionLoop, eRCSigCount) = CallByName(objRegionLoop, "signature_count", VbGet)
idxRegionLoop = idxRegionLoop + 1
Next
Sheet2.Cells.Clear
WriteRegions Sheet2, vRegions
End Sub
Private Sub WriteConstituencies(ByVal ws As Excel.Worksheet, vConstituencies)
Dim lVerticalCursor As Long
lVerticalCursor = lVerticalCursor + 1
ws.Cells(lVerticalCursor, eCCMP + 1) = "MP"
ws.Cells(lVerticalCursor, eCCName + 1) = "Name"
ws.Cells(lVerticalCursor, eCCONSCode + 1) = "ONS Code"
ws.Cells(lVerticalCursor, eCCCountry + 1) = "Country"
ws.Cells(lVerticalCursor, eCCSigCount + 1) = "Signature Count"
lVerticalCursor = lVerticalCursor + 1
Dim rngConstituencyPaste As Excel.Range
Set rngConstituencyPaste = ws.Range(ws.Cells(lVerticalCursor, eCCFirst + 1), ws.Cells(lVerticalCursor + clConsituencyCount - 1, eCCLast + 1))
'Debug.Assert rngConstituencyPaste.Columns.Count = 5
'Debug.Assert rngConstituencyPaste.Rows.Count = 650
rngConstituencyPaste.Value = vConstituencies
End Sub
Private Sub WriteRegions(ByVal ws As Excel.Worksheet, vRegions)
Dim lVerticalCursor As Long
lVerticalCursor = lVerticalCursor + 1
ws.Cells(lVerticalCursor, eRCName + 1) = "Name"
ws.Cells(lVerticalCursor, eRCONSCode + 1) = "ONS Code"
ws.Cells(lVerticalCursor, eRCSigCount + 1) = "Signature Count"
lVerticalCursor = lVerticalCursor + 1
Dim rngRegionPaste As Excel.Range
Set rngRegionPaste = ws.Range(ws.Cells(lVerticalCursor, eRCFirst + 1), ws.Cells(lVerticalCursor + clRegionCount - 1, eRCLast + 1))
'Debug.Assert rngRegionPaste.Columns.Count = 3
'Debug.Assert rngRegionPaste.Rows.Count = 12
rngRegionPaste.Value = vRegions
End Sub
Private Function SC() As ScriptControl
Static soSC As ScriptControl
If soSC Is Nothing Then
Set soSC = New ScriptControl
soSC.Language = "JScript"
'* https://stackoverflow.com/questions/45015/safely-turning-a-json-string-into-an-object
soSC.AddCode RunHttpRequest("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
End If
Set SC = soSC
End Function
Private Function RunHttpRequest(ByVal sURL As String) As String
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", sURL, False
xHTTPRequest.send
RunHttpRequest = xHTTPRequest.responseText
End Function
