JSON Strings

link - learn.microsoft.com/en-us/power-query/parse-json-xml 
link - theexcelclub.com/how-to-parse-custom-json-data-using-excel/ 
link - github.com/omegastripes/VBA-JSON-parser 
link - medium.com/swlh/excel-vba-parse-json-easily-c2213f4d8e7a 

VBA-JSON - GitHub

link - github.com/VBA-tools/VBA-JSON 

Parsing

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 

    p = 1 
    aTokenArray = Json_ExtractToArray(json, Pattern, True) 
    
    Set dic = CreateObject("Scripting.Dictionary") 
    
    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 bGroup1Bias As Boolean, _ 
Optional 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 

'DOES THIS SHORTHAND ABBREVIATION WORK FOR FUNCTIONS !!
Function ArrayID$(e) 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