如何使用VBA读取不同的节点xml

Question

借助Stackoverflow成员CDP1802可以进行标记，根据dict vlaue修改代码。如果childnodes在一个属性中具有相同的值要在同一单元中写入，则需要少量支持。

例如对象1和对象2具有LightingConditions，我想将其写为用“;”定义的单元格。在XMl中，第一行需要跳过或删除。

例如：

<Tag>
<Object Time="09:22:35:338" Category="Test" Date="1975">
 <SignRecognition>Display Speed Sign CORRECT</SignRecognition>
 <LightingConditions>NONE</LightingConditions>
 <Country>NONE</Country>
</Object>
<Object Time="09:22:36:493" Category="TestA" Date="20200115">
 <SpecialSigns>Warning Signs</SpecialSigns>
 <LightingConditions>NONE</LightingConditions>
 <Country>NONE</Country>
</Object>

</Tagging>

代码：

Function fnReadXMLByTags()
   Dim sFilePath, sFilePathFull, sFileName, sFileText, sLine As String
   Dim iLastRow As Long
   Dim oXMLFile, objNodeList As Object

   'Specify File Path
   sFilePath = "C:\Users"

   'Check for back slash
   If Right(sFilePath, 1) <> "\" Then
     sFilePath = sFilePath & "\"
   End If

   Dim mainWorkBook As Workbook
   Set mainWorkBook = ActiveWorkbook
   mainWorkBook.Sheets("Sheet1").Range("A:A").Clear

   Dim dict
    Set d = CreateObject("Scripting.Dictionary")
    d.Add "Object", "K"
    d.Add "SignsandSituations", "B"
    d.Add "SignRecognition", "C"
    d.Add "SpecialSigns", "D"
    d.Add "LightingConditions", "E"
    d.Add "Country", "F"


   sFileName = Dir(sFilePath & "*.xml")
   Do While Len(sFileName) > 0

     sFilePathFull = sFilePath & sFileName
     MsgBox "Reading " & sFilePathFull

     Open sFilePathFull For Input As #1
     While EOF(1) = False
       Line Input #1, sLine
       If InStr(sLine, "<""!DOCTYPE Tags>"">") Then
         ' skip header
       Else
         sFileText = sFileText & sLine & vbCrLf
       End If
     Wend
     Close #1
     Debug.Print sFileText

     iLastRow = Sheets("Sheet1").Cells(Rows.count, "F").End(xlUp).Row
     Set oXMLFile = CreateObject("Microsoft.XMLDOM")
     oXMLFile.LoadXML sFileText
     Set objNodeList = oXMLFile.SelectNodes("/Taginfo/Object")

     ' process nodes
     Dim obj, node, col, count, cell As Range
     With mainWorkBook.Sheets("Sheet1")
       For Each obj In objNodeList
         count = 0
         For Each node In obj.ChildNodes
           Debug.Print node.Tagname, node.Text
           If d.exists(node.Tagname) Then
             count = count + 1
             col = d(node.Tagname)
             Set cell = .Range(col & iLastRow + 1)
             If Len(cell.Value) = 0 Then
               cell.Value = node.Text
             Else
               cell.Value = cell.Value & "," & node.Text
             End If
           End If
         Next
         If count > 0 Then
            iLastRow = iLastRow + 1
         End If
       Next
     End With

     sFileName = Dir
   Loop
 End Function

Answer 1

原则上，此代码构建了所有节点的列表，并使用字典来检查存在哪些所需的节点。

已更新以忽略标题

 Function fnReadXMLByTags()
   Dim sFilePath, sFilePathFull, sFileName, sFileText, sLine As String
   Dim iLastRow As Long
   Dim oXMLFile, objNodeList As Object

   'Specify File Path
   sFilePath = "C:\temp"

   'Check for back slash
   If Right(sFilePath, 1) <> "\" Then
     sFilePath = sFilePath & "\"
   End If

   Dim mainWorkBook As Workbook
   Set mainWorkBook = ActiveWorkbook
   mainWorkBook.Sheets("Sheet1").Range("A:A").Clear

   Dim dict
   Set dict = CreateObject("Scripting.Dictionary")
   dict.Add "SignsandSituations", "B"
   dict.Add "SignRecognition", "C"
   dict.Add "SpecialSigns", "D"
   dict.Add "LightingConditions", "E"
   dict.Add "Country", "F"

   sFileName = Dir(sFilePath & "*.xml")
   Do While Len(sFileName) > 0

     sFilePathFull = sFilePath & sFileName
     MsgBox "Reading " & sFilePathFull

     Open sFilePathFull For Input As #1
     While EOF(1) = False
       Line Input #1, sLine
       If InStr(sLine, "<""!Details"">") Then
         ' skip header
       Else
         sFileText = sFileText & sLine & vbCrLf
       End If
     Wend
     Close #1
     Debug.Print sFileText

     iLastRow = Sheets("Sheet1").Cells(Rows.count, "F").End(xlUp).Row
     Set oXMLFile = CreateObject("Microsoft.XMLDOM")
     oXMLFile.LoadXML sFileText
     Set objNodeList = oXMLFile.SelectNodes("/Tagging/Object")

     ' process nodes
     Dim obj, node, col, count, cell As Range
     With mainWorkBook.Sheets("Sheet1")
       For Each obj In objNodeList
         count = 0
         For Each node In obj.ChildNodes
           'Debug.Print node.Tagname, node.Text
           If dict.exists(node.Tagname) Then
             count = count + 1
             col = dict(node.Tagname)
             Set cell = .Range(col & iLastRow + 1)
             If Len(cell.Value) = 0 Then
               cell.Value = node.Text
             Else
               cell.Value = cell.Value & "," & node.Text
             End If
           End If
         Next
         If count > 0 Then
            iLastRow = iLastRow + 1
         End If
       Next
     End With

     sFileName = Dir
   Loop
 End Function