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

Question

借助 Whosebug 成员 CDP1802 可以标记，根据 dict vlaue 修改代码。如果子节点在一个属性中具有相同的值想要将其写入同一单元格，则需要少量支持。

Ex : 对象 1 和对象 2 有 LightingConditions，我想把它写在用“;”定义的同一个单元格中.在 XMl 中，第一行需要被跳过或删除。 eachh xml value 需要写在一个coloumn , next xml file to next coloumn

例如：

<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\anandi5h\Desktop\CFRAME\Austin_Martin\test_Xml"

   '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", "B"
    D.Add "SignsandSituations", "D"
    D.Add "SignRecognition", "E"
    D.Add "SpecialSigns", "F"
    D.Add "LightingConditions", "J"
    D.Add "Country", "K"


   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, "K").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

       Next
     End With

     sFileName = Dir
   Loop
 End Function

Answer 1

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

已更新以忽略 header


     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

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

How to read different nodes xml using VBA

xml

excel

vba

xml-parsing