Как читать разные узлы xml с помощью VBA - PullRequest
Новая
       6

Как читать разные узлы xml с помощью VBA

1 голос
/ 17 января 2020

С помощью Stackoverflow Member CDP1802, который можно пометить, измените код в соответствии с требованиями dict. Нужна небольшая поддержка, если дочерние узлы имеют одно и то же значение в одном атрибуте и хотят записать его в одну и ту же ячейку.

Пример: Объект 1 и Объект 2 имеют LightingConditions, я хочу записать его в той же ячейке, определенной с помощью ";" , А в XMl первую строку нужно пропустить или удалить. Каждое xml значение должно быть записано в один столбец, следующий 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\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

1 Ответ

1 голос
/ 18 января 2020

В принципе, этот код создает список всех узлов и использует словарь, чтобы проверить, какие из них существуют.

ОБНОВЛЕНО, чтобы игнорировать заголовок 


     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
...