get data from a JSON string according to the value of another cell

Question

I'm looking for an idea to help me extract the data from one cell("data"). When the value from another cell ("id") is for example 11, I want to display the corresponding parsed value from "data" into rows and columns from another Excel-Worksheet.I'm using the library (VBA-JSON v2.3.1 JsonConverter)

I have the following JSON-Object:

 {

"Messages":[
    {
        "internalDeviceId":11,
        "rawJson":"{\"temperature\":22.6,\"humidity\":37,\"light\":1,\"motion\":1,\"co2\":640,\"vdd\":3.647}"
    },
    {
        "internalDeviceId":12,
        "rawJson":"{\"humidity\":30,\"pressure\":1000,\"CO2\":700,\"vdd\":3.654}"
    },
    {
        "internalDeviceId":13,
        "rawJson":"{\"latitude\":47.654,\"longitude\":9.654,\"vdd\":3.432}"
    },
    {
        "internalDeviceId":11,
        "rawJson":"{\"temperature\":23.0,\"humidity\":38,\"light\":20,\"motion\":0,\"co2\":665,\"vdd\":3.621}"
    },
{
        "internalDeviceId":11,
        "rawJson":"{\"temperature\":22.1,\"humidity\":35,\"light\":15,\"motion\":1,\"co2\":650,\"vdd\":3.425}"
    }
  ]
}

I got the data from a rest API with a VBA code and that is working. At the moment I get the following information in excel:

My code looks like this:

        Dim response2 As String
        Dim json1 As Object
        Dim ws2 As Worksheet
        strUrl = "https://xxxxxxxxxxxx/devices/11/"
        Set hReq = CreateObject("MSXML2.XMLHTTP")

        With hReq
            Set ws2 = Worksheets(3)
            .Open "GET", strUrl, False
            .SetRequestHeader "Authorization", "Bearer " & apitoken
            .Send
            response2 = hReq.responseText
            Set json1 = JsonConverter.ParseJson(response2)
            k = 2
                For Each item In json1("Messages")
                ws2.Cells(k, 3) = item("externalDeviceId")
                ws2.Cells(k, 8) = item("rawJson")
                k = k + 1
                Next item
         End With

I just want to split the information from "data" in rows and columns based on a certain "id" for example in this case 11. The structure from "data" depends on "id". I want to do this in VBA without PowerQuery. I was searching for hours and didn't find a solution.

I know that the item I am returning is, itself, a JSON string. To split the information from it, I create another JSON object. I don't know how I can get the information from data into rows and columns because of the different structures of "data".

How can I access these different values depending on the "id"?

Answer 1

Assuming you will want to handle all id cases being written to same range then you could use a helper dict, initialised with all the possible column headers (keys of rawJson dictionary) and with empty values. As you process each intended row to write out, item("rawJson"), simply overwrite the existing vbNullString values where present in both dictionaries. Keys not present in current row will be left with vbNullString values, due to On Error Resume Next wrapper inside helper function.

If you only care about id = 11 then add in an If ... End If

For Each item In json1
    id = item("internalDeviceId")
    If id = 11 Then
        Set dict = GetHomogenousRow(id, headers, item("rawJson"))
        r = r + 1
        .Cells(r, 1).Resize(1, dict.Count) = Application.Transpose(dict.Values)
    End If
Next

If you are intending to pick up id from the sheet that is also easy enough to incorporate, though I don't know what would stop each call with id of 11 from being identical; unless website updates very rapidly and there were a timestamp field - seems unlikely for basic weather info.

---

N.B. Not tested. Please provide valid json sample.

---

Option Explicit

Public Sub WriteOutObservations()
    Dim response2 As String, url As String, hReq As Object, apitoken As String
    
    url = "https://xxxxxxxxxxxx/devices/11/"
    apitoken = "xyz"
    Set hReq = CreateObject("MSXML2.XMLHTTP")
    
    With hReq
        .Open "GET", url, False
        .SetRequestHeader "Authorization", "Bearer " & apitoken
        .Send
        response2 = hReq.responseText
    End With
    
    Dim headers(), id As Long, json1 As Object
    Dim item As Object, r As Long, ws2 As Worksheet
    
    headers = Array("id", "temperature", "humidity", "light", "motion", "co2", "vdd")
    
    Set json1 = JsonConverter.ParseJson(response2)
    Set ws2 = ThisWorkbook.Worksheets("Sheet3")
    r = 1
    
    With ws2
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        For Each item In json1
            id = item("internalDeviceId")
            Set dict = GetHomogenousRow(id, headers, item("rawJson"))
            r = r + 1
            .Cells(r, 1).Resize(1, dict.Count) = Application.Transpose(dict.Values)
        Next
    End With

End Sub

Public Function GetHomogenousRow(ByVal id As Long, ByRef headers As Variant, ByVal inputDict As Scripting.Dictionary) As Scripting.Dictionary

    Dim dict As Scripting.Dictionary, i As Long, key As Variant

    Set dict = New Scripting.Dictionary

    For i = LBound(headers) To UBound(headers)
        dict.Add headers(i), vbNullString
    Next
    
    dict("id") = id
    On Error Resume Next                         'ignore where key not present
    For Each key In dict.Keys
        dict(key) = inputDict(key)
    Next
    On Error GoTo 0
    
    Set GetHomogenousRow = dict
End Function