使用 VBA 解析 JSON 以循环遍历 JSON 对象的所有组件并提取每个组件的标签、键、值

Question

我有一个 VBA 代码可以 parse 一些特定的 JSON 文件并从不同的 depths/layers 获取 array("components")。一旦找到任何组件，它就会提取它的 label 并检查它是否包含 columns、data 或 values.

如果找到列，则再次检查它是否包含组件
如果找到数据，则检查它是否包含值
如果找到值，则提取其“标签”和“值”

以下代码完成了大部分工作，但有些并不完美。它在 90% 的时间内得出正确的结果。

我正在寻找可以遵循相同模式但可以尽可能深入并从它的每个组件中提取“标签”、“键”和“值”的 loop可以找到。

可能的路径方式有（使用JSON编辑器在线想象不同JSON的结构）：

组件 > 组件 > 列 > 组件 > 数据 > 值
组件 > 组件 > 列 > 组件 > 值
组件 > 组件 > 数据 > 值
组件 > 组件 > 值
组件 > 列 > 组件 > 数据 > 值
组件 > 列 > 组件 > 值
组件 > 数据 > 值
组件 > 值

简而言之，对于找到的每个组件，它都会检查列是否存在，或者数据是否存在，或者值是否存在。

如果我遵循以下代码的相同结构，那么它将是很多重复的代码，因此我正在寻找一种可以完成上述所有工作但行数较少的高效代码。我认为该循环将是答案，但我不确定如何在以下代码中使用它。

我一直在使用 JsonConverter 解析 JSON 文件，然后使用以下代码：

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

FaneDuru 示例：

components 的集合包含 label 和 key，如下所示：

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

所以我需要像我之前的 VBA 代码那样将标签及其键存储在字典中。

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

同样适用于 collection/Object Values 例如：

"标签":"Anschreiben",

“价值”：“anschreiben”
"label":"Arbeitsvertrag",

“价值”：“arbeitsvertrag”
"label":"Dienstwagenüberlassungsvertrag",

“价值”：“dienstwagenuberlassungsvertrag”
"label":"Prämie Empfehlung Kollegen",

“价值”：“pramieEmpfehlungKollegen”

这里我需要将所有 label 及其 value 存储在字典中，就像我之前的 VBA 代码所做的那样。

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

Answer 1

请尝试下一种方式：

首先在模块顶部（在声明区域）创建一个字典Private变量：

 Private dict As New Scripting.Dictionary

然后使用下一个代码。就像我在评论中尝试解释的那样，它分析了集合对象 Type 并根据三个类别进行操作：Collection Type、Dictionary Type 和字符串。递归 Sub 处理所有找到的字典：

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

但是你必须知道一些字典键和代码有多次出现（因为你的已经构建并被用作模型）returns 只有第一个，按照迭代顺序。我可以将代码调整为 returns 所有这些（如果是的话，现有的除外）。我的意思是对于同一个键，字典值将包含所有由“|”或其他字符分隔的“键”值。或者使其成为最后一次出现的 return 代码会更快而不是初步检查密钥是否存在。

使用 VBA 解析 JSON 以循环遍历 JSON 对象的所有组件并提取每个组件的标签、键、值

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

arrays

parsing

vba

json

dictionary