Start with learning how to read the json structure. You can paste the json string in a json viewer. You then get a nice view of the structure. In VBA JSON the [] denote a collection you can For Each over or access by index, and the {} denotes a dictionary you can For Each the keys of, or access by specific key.
If you put your json into a viewer you should be reading it something like as follows:
Excel version for use as template:
Accessing all items:
The following shows one way of emptying the entire json into an array (you could amend for adding to recordset?)
Option Explicit
Public Sub EmptyJsonIntoArray()
Dim json As Object, r As Long, c As Long, results(), counter As Long
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.gov.uk/bank-holidays.json", False
.Send
Set json = JsonConverter.ParseJson(.responsetext) 'dictionary with 3 keys
End With
Dim key As Variant, innerKey As Variant, col As Collection
Dim division As String, headers(), item As Object, arr()
arr = json.keys
headers = json(arr(LBound(arr)))("events").item(1).keys 'take first innermost dictionary keys as headers for output
'oversize array as number of events can vary by division
ReDim results(1 To 1000, 1 To UBound(headers) + 2) '4 is the number of keys for each event level dictionary. +1 so can have _
division included as first column in output and +1 to move from 0 based headers array to 1 based results
r = 1 'leave first row for headers
results(1, 1) = "Division"
For c = LBound(headers) To UBound(headers)
results(1, c + 2) = headers(c) 'write out rest of headers to first row
Next
For Each key In json.keys 'england-and-wales etc. division
division = key
For Each item In json(division)("events") 'variable number of events dictionaries within collection
r = r + 1: c = 2 'create a new row for event output. Set column to 2 (as position 1 will be occupied by division
results(r, 1) = division
For Each innerKey In item.keys 'write out innermost dictionary values into row of array
results(r, c) = item(innerKey)
c = c + 1
Next
Next
Next
'transpose array so can redim preserve the number of rows (now number of columns) to only required number based on current value of r
results = Application.Transpose(results)
ReDim Preserve results(1 To UBound(headers) + 2, 1 To r)
results = Application.Transpose(results) 'transpose array back
'STOP '<== View array
End Sub
Sample of results contents:
Access:
From feedback by OP. With Access there is no Application.Transpose. Instead array can be passed to the following functionsource. However, the array must then be 0 based that is passed.
Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
Access version as appended by OP:
In addition to TransposeArray above (edited below to work in this case), here's the full code for Access:
Option Compare Database
Option Explicit
Public Sub UpdateBankHolidays()
Dim dbs As DAO.Database
Dim tBH As Recordset
Dim i, r, c As Long
Set dbs = CurrentDb
'Set recordset variable as existing table (in this case, called "z_BankHolidays")
Set tBH = dbs.OpenRecordset("z_BankHolidays")
'Download and parse json
Dim json As Object, results(), counter As Long
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.gov.uk/bank-holidays.json", False
.Send
Set json = ParseJson(.responsetext) 'dictionary with 3 keys
End With
Dim key As Variant, innerKey As Variant, col As Collection
Dim division As String, headers(), item As Object, arr()
arr = json.Keys
headers = json(arr(LBound(arr)))("events").item(1).Keys 'take first innermost dictionary keys as headers for output
'oversize array as number of events can vary by division
ReDim results(1 To 1000, 1 To UBound(headers) + 2) '4 is the number of keys for each event level dictionary. +1 so can have _
division included as first column in output and +1 to move from 0 based headers array to 1 based results
r = 1 'leave first row for headers
results(1, 1) = "Division"
For c = LBound(headers) To UBound(headers)
results(1, c + 2) = headers(c) 'write out rest of headers to first row
Next
For Each key In json.Keys 'england-and-wales etc. division
division = key
For Each item In json(division)("events") 'variable number of events dictionaries within collection
r = r + 1: c = 2 'create a new row for event output. Set column to 2 (as position 1 will be occupied by division
results(r, 1) = division
For Each innerKey In item.Keys 'write out innermost dictionary values into row of array
results(r, c) = item(innerKey)
c = c + 1
Next
Next
Next
'transpose array so can redim preserve the number of rows (now number of columns) to only required number based on current value of r
results = TransposeArray(results)
ReDim Preserve results(0 To UBound(results), 0 To r)
results = TransposeArray(results) 'transpose array back
'Clear all existing bank holidays from recordset
dbs.Execute "DELETE * FROM " & tBH.Name & ";"
'Insert array results into tBH recordset, transforming the date into a date value using a dd/mmm/yyyy format (in the array they are currently yyyy-mm-dd)
For i = 1 To r
If results(i, 1) = "england-and-wales" Then
dbs.Execute " INSERT INTO " & tBH.Name & " " _
& "(Title,Holiday,Notes) VALUES " _
& "('" & results(i, 2) & "', " & _
"'" & DateValue(Right(results(i, 3), 2) & "/" & Format("20/" & Mid(results(i, 3), 6, 2) & "/2000", "mmm") & "/" & Left(results(i, 3), 4)) & "', " & _
"'" & results(i, 4) & "'" & _
");"
End If
Next
'Finish
MsgBox "Bank Holidays updated."
End Sub
It's also worth noting that I (OP) had to change X and Y in the TransposeArray to start from 1, not 0 (even though, as noted above and in comments, subsequently redimming it must be based at 0). I.e.:
Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 1 To Xupper
For Y = 1 To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
[]denotes an array, not aCollection. - Mathieu Guindon