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

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

如果找到列，则再次检查它是否包含组件
如果找到数据，则检查它是否包含值
如果找到值；标签"；以及"；值">

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

我正在寻找一种CCD_ 9，它可以遵循相同的模式；标签"键"；以及"；值"；从它能找到的每一个组件。

可能的路径方式是(使用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，如下所示：

"标签"："Ausstelldatum für alle Dokumente lautet"键"："aussteldatumFurAlleDokumenteLautet"；

所以我需要像以前的VBA代码一样，将标签及其键存储在Dictionary中。

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

示例中的集合/对象Values也是如此：

"；标签"："Anschreiben"；，
"值"："anschreiben"；
"标签"："Arbeitsvertrag"；，
"值"："arbeitsvertrag"；
"标签"："Dienstwagenüberlasungsvertrag"；，
"值"："dienstwagenubellangsvertrag"；
"标签"："Prämie Empfehlung Kollegen"；，
"值"："pramieEmpfehlungKollegen"；

这里我需要像以前的VBA代码一样，将所有label及其value存储在Dictionary中。

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

请尝试下一种方法：

首先在模块顶部(声明区域(创建一个字典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:UsersFane BranestiDownloadsnew 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

但您必须知道，某些字典键多次出现，并且代码(因为您的代码已经构建并作为模型(根据迭代顺序只返回第一个。我可以调整代码以返回所有代码(exept existing，如果情况允许的话(。我的意思是，对于相同的关键字，字典值将包含所有"；键"；让我们说|&"；，或其他一些字符。或者让它返回最后一次出现，代码会更快，而不是初步检查密钥是否存在。

相关内容

最新更新

热门标签：