Parse JSON using VBA to Loop through all the components of JSON objects and extract label, key, value of each components

Question

I have a VBA code that can parse some particular JSON files and get the array("components") from different depths/layers. Once any components is found, it then extract it's label and check if it contains columns, data, or values.

if columns is found then again check if it contains components
if data is found then check if it contains values
if values is found then extract its "label" and "value"

Following code is doing most of it, but some how not perfect. It come up with correct results 90% of the time.

I am in a search of a loop that can follow the same pattern but can go deeper as much as it can and extract the "label", "key" and "value" from every component it can find.

Possible path ways are (used JSON editor online to imagine the structure of different JSON):

components > components > columns > components > data > values
components > components > columns > components > values
components > components > data > values
components > components > values
components > columns > components > data > values
components > columns > components > values
components > data > values
components > values

In nutshell, for every components found, it will check, if columns exits, or data exist, or values exits.

if I follow the same structure of the following code then it would be a lot of repeated code so I am in a search of a efficient code that can do all above but in less number of lines. I think that loop will be the answer, but I am not sure how to utilize it in following code.

I have been using JsonConverter to parse JSON file and then using following code:

Private Sub Test()
    '==== Change this part according to your implementation..."
    Dim jsontxt As String
    jsontxt = OpenTxtFile("D:/TestJSON2.txt")
    '====

    Dim jSon As Scripting.Dictionary
    Set jSon = JsonConverter.ParseJson(jsontxt)
            
    'Check if first level of components exist and get the collection of components if true

    If jSon.Exists("components") Then
        Dim components As Collection
        Set components = jSon("components")
        
        Set Dict = New Scripting.Dictionary
        Set DictValue = New Scripting.Dictionary
        
        Dim comFirst As Variant
        Dim comSecond As Variant
        Dim comThird As Variant
        Dim columnsDict As Variant
        Dim valDict As Variant
                    
        For Each comFirst In components
            If Not Dict.Exists(comFirst("label")) Then Dict.Add comFirst("label"), comFirst("key")
            
Columns:
    If comFirst.Exists("columns") Then
        For Each columnsDict In comFirst("columns")
        
            If columnsDict.Exists("components") Then
                For Each comSecond In columnsDict("components")
                
                    If Not Dict.Exists(comSecond("label")) Then Dict.Add comSecond("label"), comSecond("key")
                    If comSecond.Exists("data") Then
                        If comSecond("data").Exists("values") Then
                            For Each valDict In comSecond("data")("values")
                                If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                            Next valDict
                        End If
                    End If
                    If comSecond.Exists("values") Then
                        For Each valDict In comSecond("values")
                            If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                        Next valDict
                    End If
                    
                Next
            End If
            
        Next
    End If

Data:
    If comFirst.Exists("data") Then
        If comFirst("data").Exists("values") Then
            For Each valDict In comFirst("data")("values")
                If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
            Next valDict
        End If
    End If

Values:
    If comFirst.Exists("values") Then
        For Each valDict In comFirst("values")
            If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
        Next valDict
    End If

            
            
            
            '++++ New JSON Format ++++
            '==== Check if second level of "components" key exist and extract label-key if true
            If comFirst.Exists("components") Then
            
                For Each comSecond In comFirst("components")
                    If Not Dict.Exists(comSecond("label")) Then Dict.Add comSecond("label"), comSecond("key")
                                    
                    '=== Check if "columns" key exist and extract the key-label if true
                    If comSecond.Exists("columns") Then
                        For Each columnsDict In comSecond("columns")
                        
                            '==== Check if third level of "components" key exist and extract key-label if true
                            If columnsDict.Exists("components") Then
                                For Each comThird In columnsDict("components")
                                    If Not Dict.Exists(comThird("label")) Then Dict.Add comThird("label"), comThird("key")
                                    
                                    If comThird.Exists("data") Then
                                        If comThird("data").Exists("values") Then
                                            For Each valDict In comThird("data")("values")
                                                If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                                            Next valDict
                                        End If
                                    End If

                                    '==== Check if "values" key exist and extract label-value if true
                                    If comThird.Exists("values") Then
                                        For Each valDict In comThird("values")
                                            If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                                        Next valDict
                                    End If
                                    '====
                                    
                                Next comThird
                            End If
                            '====
                            
                        Next columnsDict
                    End If
                    '====
                    
                    
    
                    If comSecond.Exists("data") Then
                        If comSecond("data").Exists("values") Then
                            For Each valDict In comSecond("data")("values")
                                If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                            Next valDict
                        End If
                    End If

                    '==== Check if "values" key exist and extract the label-value if true
                    If comSecond.Exists("values") Then
                        For Each valDict In comSecond("values")
                            If Not DictValue.Exists(valDict("label")) Then DictValue.Add valDict("label"), valDict("value")
                        Next valDict
                    End If
                    '====
                Next comSecond
            End If
            '++++
            
        Next comFirst
    End If

Example for FaneDuru:

Collection of components contain label and key as follows:

"label":"Ausstelldatum für alle Dokumente lautet", "key":"ausstelldatumFurAlleDokumenteLautet"

So I need to store label and its key in Dictionary as my previous VBA code already doing.

Dict.Add comFirst("label"), comFirst("key")

Same goes for collection/Object Values in example:

"label":"Anschreiben",

"value":"anschreiben"
"label":"Arbeitsvertrag",

"value":"arbeitsvertrag"
"label":"Dienstwagenüberlassungsvertrag",

"value":"dienstwagenuberlassungsvertrag"
"label":"Prämie Empfehlung Kollegen",

"value":"pramieEmpfehlungKollegen"

here I need to store all the label and its value in Dictionary as my previous VBA code already doing.

DictValue.Add valDict("label"), valDict("value")

It should be good to share "TestJSON2.txt" you tested and more specifically explain what problem(s) does the above code produces. 90% does not help at all, in order to localize the problem(s) you try talking about. If one between the shared json files is the one your code processes, please, specify which of them it is. — FaneDuru
– FaneDuru, Commented Jan 25, 2022 at 12:41
OK. So, you need to return all found "label"/"key" nodes and their value, for all levels. Is this understanding correct? If so, how would you like them to be returned? If not, what else would you like to be returned and in which way? — FaneDuru
– FaneDuru, Commented Jan 25, 2022 at 18:37
We have two dictionaries. We will add components label,key in one dictionary and values label, value in another dictionary. As we are already doing. Please check the code. But problem is it can only dig 3 step down, so I'm searching for a loop that can find every components and get it label and key. — VBAbyMBA
– VBAbyMBA, Commented Jan 25, 2022 at 19:50
In the meantime I already prepared an answer returning in Immediate Window. Anyhow, since the dictionary key should all the time be "label", it cannot be loaded more then once. No time to try better understanding your code logic. Please, check the answer II will post and see how a function reading the involved dictionaries should be used. — FaneDuru
– FaneDuru, Commented Jan 25, 2022 at 20:12

FaneDuru · Accepted Answer · 2022-01-27 21:03:56Z

1

Please, try the next way:

Firstly create a dictionary Private variable on top of the module (in the declarations area):

 Private dict As New Scripting.Dictionary

Then use the next code. Like I tried explaining in my comment, it analize the collection objects Type and acts according to three categories: Collection Type, Dictionary Type and strings. A recursive Sub processes all found dictionaries:

Private Sub TestJsonElem()
    Dim jsontxt As String, strFile As String, El, dKey, i As Long, j As Long
    strFile = "C:\Users\Fane Branesti\Downloads\new 12.json"
    jsontxt = CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 1).ReadAll
 
    dict.RemoveAll
    Dim jSon As Scripting.Dictionary
    Set jSon = JsonConverter.ParseJSON(jsontxt)
   
    If jSon.Exists("components") Then
        Dim C1 As Collection: Set C1 = jSon("components")
        
        For Each El In C1                                  'iterate between collection elements
            If TypeName(El) = "Dictionary" Then            'in case of a dictionary
                For i = 0 To El.count - 1                  'iterate between the dictionary items/keys
                    Select Case TypeName(El.Items()(i))    'act according to dictionary item type:
                         Case "Dictionary"                 'if a dictionary:
                                processDict El.Items()(i)  'send it to the recursive Sub extracting labels
                         Case "Collection"                 'iterate between coll elements and send the dictionaries
                                                           'to recursive Sub
                                For j = 1 To El.Items()(i).count
                                    processDict El.Items()(i)(j) 'send each dictionary to recursive Sub
                                Next j
                         Case Else                               'if no object (String, Boolean, Null):
                                If El.Keys()(i) = "label" Then   'and it is "label"
                                   'place the dictionary "label" as key and dictiorary "key" as value
                                    If Not dict.Exists(El("label")) Then _
                                          dict(El("label")) = IIf(El("key") = "", "Empty", El("key"))
                                End If
                     End Select
                Next i
            End If
        Next
    End If
    'return the dictionary keys/items:
    For i = 0 To dict.count - 1
        Debug.Print dict.Keys()(i) & " : " & dict.Items()(i)
    Next i
End Sub

Sub processDict(ByVal d As Scripting.Dictionary)
    Dim i As Long, j As Long
    For i = 0 To d.count - 1                                   'iterate between the dictionary items/keys
            If TypeName(d.Items()(i)) = "Collection" Then      'in case of a collection iterate between its dictionaries
                For j = 1 To d.Items()(i).count
                    processDict d.Items()(i)(j)                'call the Sub itself recursively
                Next j
            ElseIf TypeName(d.Items()(i)) = "Dictionary" Then
                processDict d.Items()(i)                       'call the Sub itself recursively
            Else
                 If d.Keys()(i) = "label" Then
                         'place the dictionary "label" as key and dictiorary "key" as value
                         If Not dict.Exists((d("label"))) Then _
                                  dict(d("label")) = IIf(d("key") = "", "Empty", d("key"))
                End If
            End If
    Next i
End Sub

But you must know that there are multiple occurrences for some dictionary keys and the code (as yours has been built and taken as model) returns only the first one, according to the iteration order. I can adapt the code to returns all of them (exept existing, if the case). I mean for the same key the dictionary value will contain all "key" values separated by, let us say "|", or some other character. Or make it to return the last occurrence and the code will be faster not preliminary checking if the key exists.

edited Jan 27, 2022 at 21:03

answered Jan 25, 2022 at 20:17

FaneDuru

42.3k4 gold badges22 silver badges30 bronze badges

Sign up to request clarification or add additional context in comments.

15 Comments

VBAbyMBA Over a year ago

Hi! thanks for the quick response, code is working. but as already described in question that I need label text added to another dictionary with its key. by using If Not Dict.Exists("label") Then Dict.Add "label", "key" can you guide me how I can extract both?

FaneDuru Over a year ago

@Ibn e Ashiq Do you want adding the same dictionary key ("label") more than once? If so, as I tried stating in my comment, this is not possible! Scripting.Dictinary does not allow that. It is frequently used to extract unique keys from a range containing duplicates. If you want something different, please specify what you really want. If you really want dealing with a dictionary and my above mentioned understanding is correct, I can do that only using an incremented variable and build unique keys by concatenating "Label" with the variable in discussion. Resulting "lb1", "lb2", "lb3" etc

FaneDuru Over a year ago

@Ibn e Ashiq I am very busy now... I will try something else in the evening, when I will be at home. Only now I understood the meaning of the "label" and "key". I thought that the string "label" as it is must be returned and 'its value/key' should be what it follows after ":" character. That's why the same "label" string could not be accepted by a dictionary... Now, I can see that what follows after "label:" should be returned as dictionary key and what follows after "key:", as dictionary item. The iteration logic has to be changed. But I cannot do it now.

FaneDuru Over a year ago

@Ibn e Ashiq Please, test the updated code and send some feedback. It will return what (I understood.) you need...

FaneDuru Over a year ago

@Ibn e Ashiq This is what I wanted to suggest and I already was testing. But I was trying to see if there are situations when El("label") exists but neither "value" or "key" exist. Is it possible that such a situation exist? Not any error will be raised for such a case, but I was thinking that I maybe will find a way to make it return elegantly...:)

|

Collectives™ on Stack Overflow

Parse JSON using VBA to Loop through all the components of JSON objects and extract label, key, value of each components

1 Answer 1

15 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

15 Comments

Your Answer

Sign up or log in

Post as a guest

Related