VBA-Json Parse Nested Json

I combined V1 and V2 above to produce the results, which was to capture values and save them into variables. This is my edited code: (I am still working on creating all of the cases and variables)

    Dim Json As Object
    Dim FSO As New FileSystemObject
    Dim JsonTS As TextStream
    Dim JsonText As String

    Set JsonTS = FSO.OpenTextFile("C:\some.txt", ForReading) 'change as appropriate
    JsonText = JsonTS.ReadAll
    JsonTS.Close

    Dim Parsed As Dictionary

    Set Parsed = JsonConverter.ParseJson(JsonText)

    Dim initialCollection  As Collection

    Set initialCollection = Parsed("orders")

    Debug.Print initialCollection.Count ' 1 item which is a dictionary

    Dim initialDict As Dictionary

    Set initialDict = initialCollection(1)

    Dim Key As Variant
    Dim dataStructure As String

    For Each Key In initialDict.Keys

        dataStructure = TypeName(initialDict(Key))

        Select Case dataStructure

        Case "Dictionary"

        Dim Key1 As Variant

        For Each Key1 In initialDict(Key).Keys

           Select Case TypeName(initialDict(Key)(Key1))

           Case "String"

              'Debug.Print Key & " " & Key1 & " " & initialDict(Key)(Key1) 'amount/currency/symbol


                        'because the Key1 (amount) is the same for each Key ("Amount_product", "Amount_product_subtotal", and so on; (see Json above) I needed to concatenate them to extract unique values
                        Select Case Key & "_" & Key1


                        'first set of values "Amount_Product"
                        Case "Amount_product_amount"

                            dAmount_product_amount = initialDict(Key)(Key1)

                        Case "Amount_product_currency"

                            sAmount_product_currency = initialDict(Key)(Key1)

                        Case "Amount_product_symbol"

                            sAmount_product_symbol = initialDict(Key)(Key1)


                        'second set of values "Amount_Product_Subtotal"

                        Case "Amount_product_subtotal_amount"

                            dAmount_product_subtotal_amount = initialDict(Key)(Key1)

                        Case "Amount_product_subtotal_currency"

                            sAmount_product_subtotal_currency = initialDict(Key)(Key1)

                        Case "Amount_product_subtotal_symbol"

                            sAmount_product_subtotal_symbol = initialDict(Key)(Key1)

                        ' third set of values, and so on

                        End Select

                        'Debug.Print Key & ": " & Key1





           Case "Dictionary"

               Dim Key2 As Variant

               For Each Key2 In initialDict(Key)(Key1).Keys

                   'Debug.Print TypeName(initialDict(key)(Key1)(Key2)) 'strings and one dict

                   Select Case TypeName(initialDict(Key)(Key1)(Key2))

                       Case "String"

                           Debug.Print Key & " " & Key1 & " " & Key2 & " " & initialDict(Key)(Key1)(Key2)

                       Case "Dictionary"

                            Dim Key3 As Variant

                            For Each Key3 In initialDict(Key)(Key1)(Key2).Keys

                                'Debug.Print TypeName(initialDict(key)(Key1)(Key2)(Key3)) 'string only
                                Debug.Print initialDict(Key)(Key1)(Key2)(Key3)

                            Next Key3

                   End Select

               Next Key2

           Case Else

               MsgBox "Oops I missed this one"

           End Select

        Next Key1

        Case "String", "Boolean", "Double"

           Debug.Print Key & " : " & initialDict(Key)

        Case "Collection"

            'Debug.Print TypeName(initialDict(key)(1)) 'returns  1  Dict
            Dim Key4 As Variant

            For Each Key4 In initialDict(Key)(1).Keys   'Debug.Print TypeName(initialDict(key)(1)(Key4)) 'returns a dictionary

                Dim Key5 As Variant

                For Each Key5 In initialDict(Key)(1)(Key4).Keys ' Debug.Print TypeName(initialDict(key)(1)(Key4)(Key5)) returns 4 dictionaries

                   Dim Key6 As Variant

                   For Each Key6 In initialDict(Key)(1)(Key4)(Key5).Keys 'returns string

                       Debug.Print Key & "  " & Key4 & "  " & Key5 & "  " & Key6 & " " & initialDict(Key)(1)(Key4)(Key5)(Key6)

                   Next Key6

                Next Key5

            Next Key4

        Case Else

            MsgBox "Oops I missed this one!"

        End Select

    Next Key

End Sub

I struggled to build this code for my needs earlier

• it collects all keys and its values even nested ones and saves them to a table after dynamically adding fields named dynamically as well based on key name .
• you just need to provide the Json string and existing table name (to save data on it) and determine where to start digging in your json collections like here : JsonDict("response")("holidays")
• then only run the function UpdateHolidaysDynamic and see your results at the table

 Sub UpdateHolidaysDynamic()
    Dim http As Object
    Dim jsonResponse As String
    Dim JsonDict As Object
    Dim Holidays As Object
    Dim Holiday As Object
    Dim db As DAO.Database
    Dim tblDef As DAO.TableDef
        
        ' Get the JSON response as a string
        jsonResponse = MyjsonText 'pass json full text here
            
        ' Parse the JSON response (use VBA-JSON or a similar parser)
        Set JsonDict = JsonConverter.ParseJson(jsonResponse)
        
        ' Access the Holidays array in the JSON response
        Set Holidays = JsonDict("response")("holidays") ' rename parameters as your needs
        
        ' Open the database
        Set db = CurrentDb
        
        ' Check if new fields need to be added
        Set tblDef = db.TableDefs("Holidays") ' rename the table name
        
             ' Build the field name using the ParentKey, if it exists
    
            
        ' Loop through each Holiday to check for fields
        For Each Holiday In Holidays
            Call CheckAndAddFields(Holiday, tblDef)
        Next Holiday
    
        ' Open the recordset and insert data after fields have been added
        Dim rs As DAO.Recordset
        Set rs = db.OpenRecordset("Holidays", dbOpenDynaset)
        
        ' Loop through each Holiday to insert data
        For Each Holiday In Holidays
            rs.AddNew
            Call ProcessJsonData(Holiday, rs)
            rs.Update
        Next Holiday
        
        ' Clean up
        rs.Close
        Set rs = Nothing
        Set db = Nothing
        Set tblDef = Nothing
    End Sub

        Sub CheckAndAddFields(JsonItem As Object, tblDef As DAO.TableDef, Optional Prefix As String = "")
        Dim key As Variant
        Dim fldName As String
        Dim Col As Collection
        Dim Dict As Dictionary
        ' Loop through each key-value pair in the JSON item
        For Each key In JsonItem
             If Prefix <> "" Then
                fldName = Prefix & "_" & key
            Else
                fldName = "H_" & key
            End If
            On Error Resume Next ' Temporarily ignore errors
    
            ' Check if the value is another JSON object (Dictionary)
            If IsObject(JsonItem(key)) Then
                If TypeOf JsonItem(key) Is Dictionary Then
                     Set Dict = JsonItem(key)
                    ' Recursively check subkeys if it's a Dictionary
                    Call CheckAndAddFields(Dict, tblDef, fldName)
                
                ' Check if the value is an array
                ElseIf TypeOf JsonItem(key) Is Collection Then
                    Set Col = JsonItem(key)
                    ' Optionally, handle arrays here
                    Debug.Print "Array found, handling omitted: " & fldName
                
                End If
            Else
                ' Check if it's a basic field and ensure that the field is added if not present
                If Not FieldExistsInTable(tblDef, fldName) Then
                    tblDef.Fields.Append tblDef.CreateField(fldName, dbText)
                    Debug.Print "Added new field: " & fldName
                End If
            End If
            On Error GoTo 0 ' Resume normal error handling
    
        Next key
        
        Set Dict = Nothing
        Set Col = Nothing
    End Sub


    Sub ProcessJsonData(JsonItem As Object, rs As DAO.Recordset, Optional Prefix As String = "")
        Dim key As Variant
        Dim fldName As String
        Dim fldValue As Variant
        Dim FldObj As Dictionary
        Dim fldCol As Collection
        Dim itemType As String
        
        On Error Resume Next
    
        ' Loop through each key-value pair in the current JSON item
        For Each key In JsonItem
            fldValue = JsonItem(key)
            'fldName = Prefix & "_" & key
            
             If Prefix <> "" Then
                fldName = Prefix & "_" & key
            Else
                fldName = "H_" & key
            End If
            
            ' Determine the type of the current item
            itemType = TypeName(JsonItem(key))
            
            ' Check if the item is a nested JSON object
            If itemType = "Dictionary" Then
                ' Recursively process nested JSON objects with the current key as the prefix
                Set FldObj = JsonItem(key)
                Call ProcessJsonData(FldObj, rs, fldName)
            ElseIf itemType = "Collection" Then
                ' Recursively process nested JSON objects with the current key as the prefix
                Set fldCol = JsonItem(key)
                Call ProcessJsonData(fldCol, rs, fldName)
            Else
                ' Handle simple types
                If FieldExistsInRecordset(rs, fldName) Then
                    rs(fldName).Value = fldValue
                Else
                    Debug.Print "Field not found in recordset: " & fldName
                End If
            End If
            
            If Err.Number <> 0 Then
                Debug.Print "Error processing key: " & fldName & " with value: " & fldValue
                Err.Clear
            End If
        Next key
    
        On Error GoTo 0
        Set FldObj = Nothing
        Set fldCol = Nothing
    End Sub
    
    ' Function to check if a field exists in the recordset
    Function FieldExistsInRecordset(rs As DAO.Recordset, fldName As String) As Boolean
        Dim fld As DAO.Field
        On Error Resume Next
        Set fld = rs.Fields(fldName)
        FieldExistsInRecordset = (Err.Number = 0)
        On Error GoTo 0
    End Function      
    
    ' Function to check if a field exists in the table
    Function FieldExistsInTable(tblDef As DAO.TableDef, fldName As String) As Boolean
        Dim fld As DAO.Field
        On Error Resume Next
        Set fld = tblDef.Fields(fldName)
        FieldExistsInTable = (Err.Number = 0)
        On Error GoTo 0
    End Function