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")
CodePudding user response：
Please, try the next way:
- Firstly create a dictionary
Privatevariable 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
Typeand acts according to three categories:Collection Type,Dictionary Typeand strings. A recursiveSubprocesses 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.