Accessing JSON array data in VBA - json

Question

I have this json array and the data I need is in the array that starts data_id which I cannot extract. I am able to extract keys,value before the array but not in the array. I believe I need to request data in a specific way with a number in () after the fieldname nest but I cannot find a beginners explanation to see what number goes in the brackets and why you chose that number.
{"api":{"results":37,"data":[{"data_id":643951,"location_id":3005,"person":{"name":"Bob","country":"Turkey",
Any tips appreciated here is some code
'Print a few object variables before parse
Dim WrkSht As Worksheet
Set WrkSht = ThisWorkbook.Worksheets("jsonoutput")
WrkSht.Cells(1, 1).Value = xml_obj.responseText
' Displays data fine in one string as shown above
'Parse the response
Set jp = JsonConverter.ParseJson(xml_obj.responseText)
For Each dict In jp
Debug.Print dict
If Not IsObject(jp(dict)) Then
Debug.Print jp(dict)
Else
For Each subDict In jp(dict)
Debug.Print subDict
'Debug.Print jp(dict)(subDict)
Next subDict
End If
Next dict
' I need to drill down into further levels but ?
End Sub

Answer 1

Here's a simple example
JSON used:
{"api":{"results":37,
"data":[{"data_id":643951,
"location_id":3005,
"person":{"name":"Bob","country":"Turkey"}
} ]
}}
Code:
Sub Test36()
Dim jso As Object, arr, data, obj
'loading from a cell for testing...
Set jso = JsonConverter.ParseJson(Sheet2.Range("A17").Value)
'jso is a Dictionary
Debug.Print jso("api")("results") '>> 37
Set data = jso("api")("data") 'data is a Collection
Debug.Print data.Count ' >> 1
For Each obj In data
Debug.Print obj("data_id") '>> 643951
Debug.Print obj("person")("country") '>> Turkey
Next obj
End Sub

Answer 2

I thought I would just share the code I ended up with. It can be improved on and some is over coded simply to make it easier to see where amendments can be made. Currently this will:
Access an API - just put as many header lines in as you need
Collect the JSON data and flatten it to one level - this code will only work with Json where
blank values are recorded as "null" rather than just "". You may
have to manually correct the columns (or update the code) for
blank values
Ask you which key you want to start with - it will
then mark that keys values to start a new row each time it comes
across this
Make replacements in the data to create delimiters
to mark which data is keys and which is values
Pastes your keys
in row 1 that have values - dictionary keys are ignored but
you can change that if needed
Remove all keys from the string to
just leave values and paste those in the rows below.
You need to have the RunScriptime XMl HTTP 6.0 and Object library ticked in Tools reference in VBA as well
Sub FlattenJsonGetDataFromKeysWithValues()
ActiveWorkbook.Worksheets("yourworksheet").Range("a1:ZZ10000").ClearContents
Dim i As Long
'Declare variables
Dim xml_obj As MSXML2.XMLHTTP60
Dim base_url As String
Dim Json1 As String, Json2, Json3, Json4, Json5, Json6, json7, Json8, Json9, Json10, Json11, Json12, Json13, Json14, Json15, Json16, Json17, Json18
Dim Json0 As String
Dim keys As String, keys2
'Create a new Request Object make sure in Tools-> reference the xml6.0, scripting runtime and object library are ticked
Set xml_obj = New MSXML2.XMLHTTP60
'Define URL Components two headers are shown but you cana dd as many as required
base_url = "https://yoururl.com"
xml_obj.Open "GET", base_url
xml_obj.SetRequestHeader "key", "55555"
xml_obj.SetRequestHeader "host", "valuefor2ndheaderkeyifneeded"
xml_obj.Send
'Print the status code in case something went wrong
MsgBox("The Request was " + CStr(xml_obj.Status))
strJson0 = xml_obj.responseText
MsgBox (Len(strJson0)) ' tells how long string is
'Look for Json current delimiters and change all to a comma
Json1 = strJson0
Const SpecialCharacters As String = "!,#,#,$,%,^,&,*,(,),{,[,],},?,:"
Dim char As Variant
For Each char In Split(SpecialCharacters, ",")
Json1 = Replace(Json1, char, " ")
Next
' Place # before all field names, I have shown in this way so if needed you can vary to suit your needs
Json2 = Replace(Json1, "," & Chr(34), "#") ' Replaces ," - Chr(34) is a "
Json3 = Replace(Json2, ", " & Chr(34), "#") ' replaces , "
Json4 = Replace(Json3, Chr(34) & " " & Chr(34), Chr(34) & "#") ' Replaces " "
Json5 = Replace(Json4, Chr(34) & " " & Chr(34), Chr(34) & "#") ' Replaces " "
'Place : after fieldname and before value
Json6 = Replace(Json5, Chr(34) & " " & Chr(34), ":") 'Replaces " "
json7 = Replace(Json6, Chr(34) & " ", ":") 'Replaces "(blankspace)
Json8 = Replace(json7, Chr(34), ":") 'Replaces "
Json9 = Replace(Json8, ":#", "#") 'Replaces :# with #
Json10 = Replace(Json9, "/", "") 'Removes /
Json11 = Replace(Json10, " ", "") 'Removes blankspace
If Left(Json11, 1) = ":" Then Json11 = "#" & Right(Json11, (Len(Json11) - 1)) ' Replace : with # if first character
' Now you just have field names (keys) marked by # and values marked by :
' Find Field Names - which field should we start with? How many times is that key in the data
Dim firstkey As String
MsgBox (Json11) 'View this to see your key/header row options
firstkey = InputBox("Enter First Field/Key to locate") 'This will mark where all new rows start
keys = Json11
' Now take text between #*# as dictionary keys and ignore and text between #*: as headers for field names until repeat text is found in string by finding the firstkey you input above and putting a # marker in all heading that = firstkey
Dim openPos As Long
Dim closePos As Long
Dim k As Integer
Dim jsonFields As Collection
Set jsonFields = New Collection
Dim jsonValues As Collection
Set jsonValues = New Collection
' Find wanted starting key, skip over keys without value
k = 1
openPos = InStr(keys, firstkey)
closePos = InStr(openPos, keys, ":")
If InStr(1, Mid(keys, openPos, closePos - openPos), "#") > 0 Then openPos = openPos + InStr(1, Mid(keys, openPos, closePos - openPos), "#")
jsonFields.Add Mid(keys, openPos, closePos - openPos)
keys = Replace(keys, firstkey & ":", ":#")
k = k + 1
' Find other keys with values, find dict keys
Do Until Mid(keys, openPos, closePos - openPos) = ""
openPos = InStr(closePos, keys, "#") + 1
If k = 2 Then openPos = InStr(1, keys, "#")
closePos = InStr(openPos, keys, ":")
If InStr(1, Mid(keys, openPos, closePos - openPos), "#") > 0 Then openPos = openPos + InStr(1, Mid(keys, openPos, closePos - openPos), "#")
jsonFields.Add Mid(keys, openPos, closePos - openPos)
k = k + 1
Loop
' Find values and remove delimiters, keys and replace : in https values that are removed with other delimiters
y = 2 ' use to start populate rows
currentcolumn = 1
Dim r&
p = Split(keys, "#")
For r = 0 To UBound(p)
If InStr(1, p(r), ":") Then p(r) = Right(p(r), Len(p(r)) - InStr(1, p(r), ":") + 1) ' remove keys
If InStr(1, p(r), ":") = 0 Then p(r) = "" ' remove :
If InStr(1, p(r), ":") Then p(r) = Right(p(r), Len(p(r)) - InStr(1, p(r), ":")) ' set value for collection to print later
If InStr(1, p(r), "https") Then p(r) = Replace(p(r), "https", "https:") ' fix https value by readding :
jsonValues.Add p(r) ' add to collection
Next r
' Print Values to worksheet
currentcolumn = 1
'Now Output your parsed key data, turn screen updating off
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each Item In jsonFields
ActiveWorkbook.Worksheets("yourworksheet").Cells(1, currentcolumn).Value = Item
currentcolumn = currentcolumn + 1
Next Item
y = 2
currentcolumn = 1
Dim ws As Worksheet
Set ws = Worksheets("yourworksheet")
For Each Item In jsonValues
If Len(Item) > 0 Then
If InStr(1, Item, "#") = 1 Then
y = y + 1
currentcolumn = 1
End If
ws.Cells(y, currentcolumn).Value = Item
currentcolumn = currentcolumn + 1
End If
Next Item
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub