Parsing

Parsing means converting the JSON into a more useful data structure such as an object or array.

Using Power Query

link - learn.microsoft.com/en-us/power-query/parse-json-xml 

VBA-JSON-parser - GitHub

link - github.com/omegastripes/VBA-JSON-parser 

Code Snippet

This uses Scripting Dictionary available from the Microsoft Scripting Runtime library.
This uses Regular Expressions available from the Microsoft VBScript Regular Expressions 5.5 library.

Dim dic As Scripting.Dictionary 
Dim p As Long 
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"  

'***********************************************************************************
Function Json_ToDictionary( _ 
         ByVal json As String, _ 
Optional ByVal key As String = "obj") _ 
         As Scripting.Dictionary 

Dim aTokenArray As Variant 

    Set dic = CreateObject("Scripting.Dictionary") 

    p = 1 
    aTokenArray = Json_ExtractToArray(json, Pattern, True) 
    
    If aTokenArray(p) = "{" Then 
       Call Json_ParseObj(aTokenArray, key) 
    Else 
       Call Json_ParseArr(aTokenArray, key) 
    End If 
    
    Set Json_ToDictionary = dic 
End Function 
'***********************************************************************************
Function Json_ExtractToArray( _ 
         ByVal sJSON As String, _ 
         ByVal Pattern As String, _ 
Optional ByVal bGroup1Bias As Boolean, _ 
Optional ByVal bGlobal As Boolean = True) _ 
         As Variant 

Dim c As Long 
Dim m As Variant 
Dim n As Variant 
Dim aValues As Variant 
  
  With CreateObject("VBScript.RegExp") 
    .Global = bGlobal 
    .MultiLine = False 
    .IgnoreCase = True 
    .Pattern = Pattern 
    
    If .TEST(sJSON) Then 
      Set m = .Execute(sJSON) 
      ReDim aValues(1 To m.Count) 
      
      For Each n In m 
        c = c + 1 
        aValues(c) = n.Value 
        If (bGroup1Bias = True) Then 
           If (Len(n.submatches(0)) Or n.Value = """""") Then 
           
              aValues(c) = n.submatches(0) 
           End If 
        End If 
      Next 
    End If 
  End With 
  
  Json_ExtractToArray = aValues 
End Function 
'***********************************************************************************
Public Sub Json_ParseObj( _ 
         ByVal aTokenArray As Variant, _ 
         ByVal key As String) 

    Do 
       p = p + 1 
        Select Case aTokenArray(p) 
            Case "]" 
            Case "[":  Call Json_ParseArr(aTokenArray, key) 
            
            Case "{" 
                       If (aTokenArray(p + 1) = "}") Then 
                           p = p + 1 
                           dic.Add key, "null" 
                       Else 
                           Call Json_ParseObj(aTokenArray, key) 
                       End If 
                
            Case "}":  key = Json_ReducePath(key): Exit Do 
            
            Case ":":  key = key & "." & aTokenArray(p - 1) 
            
            Case ",":  key = Json_ReducePath(key) 
            
            Case Else: 
               If (aTokenArray(p + 1) <> ":") Then 
                  dic.Add key, aTokenArray(p) 
               End If 
        End Select 
    Loop 
End Sub 
'***********************************************************************************
Public Function Json_ParseArr( _ 
         ByVal aTokenArray As Variant, _ 
         ByVal key As String) 
         
Dim e As Long 
Dim p As Long 
    
    Do 
       p = p + 1 
        Select Case aTokenArray(p) 
            Case "}" 
            
            Case "{":  Call Json_ParseObj(aTokenArray, key & Json_ArrayID(e)) 
            
            Case "[":  Call Json_ParseArr(aTokenArray, key) 
            
            Case "]":  Exit Do 
            
            Case ":":  key = key & Json_ArrayID(e) 
            
            Case ",":  e = e + 1 
            
            Case Else: 
               dic.Add key & Json_ArrayID(e), aTokenArray(p) 
        End Select 
    Loop 
End Function 
'***********************************************************************************
Public Function Json_ArrayID( _ 
         ByVal e As Variant) _ 
         As String 

    Json_ArrayID = "(" & e & ")" 
End Function 
'***********************************************************************************
Public Function Json_ReducePath( _ 
         ByVal key As String) _ 
         As String 

    If (InStr(key, ".") > 0) Then 
       Json_ReducePath = Left(key, InStrRev(key, ".") - 1) 
    Else 
       Json_ReducePath = key 
    End If 
End Function 
'***********************************************************************************
Public Function Json_ListPaths( _ 
         ByRef dic As Scripting.Dictionary) 

Dim s As String 
Dim v As Variant 
    
    For Each v In dic 
        s = s & v & " --> " & dic(v) & vbLf 
    Next 
    
'    Debug.Print s
End Function 
'***********************************************************************************
Public Function Json_GetFilteredTable( _ 
      ByRef dic As Scripting.Dictionary, _ 
      ByVal cols As Variant) _ 
      As Variant 

Dim c As Long 
Dim i As Long 
Dim j As Long 
Dim v As Variant 
Dim w As Variant 
Dim z As Variant 
    
    v = dic.Keys 
    z = Json_GetFilteredValues(dic, cols(0)) 
    
    ReDim w(1 To UBound(z), 1 To UBound(cols) + 1) 
    
    For j = 1 To UBound(cols) + 1 
         z = Json_GetFilteredValues(dic, cols(j - 1)) 
         For i = 1 To UBound(z) 
            w(i, j) = z(i) 
         Next 
    Next 
    
    Json_GetFilteredTable = w 
End Function 
'***********************************************************************************
Function Json_GetFilteredValues( _ 
         ByRef dic As Scripting.Dictionary, _ 
         ByVal match As Variant) _ 
         As Variant 

Dim c As Long 
Dim i As Long 
Dim v As Variant 
Dim w As Variant 
    
    v = dic.Keys 
    
    ReDim w(1 To dic.Count) 
    
    For i = 0 To UBound(v) 
        If v(i) Like match Then 
            c = c + 1 
            w(c) = dic(v(i)) 
        End If 
    Next 
    ReDim Preserve w(1 To c) 
    
    Json_GetFilteredValues = w 
End Function