How to read different nodes xml using VBA

Question

With the help of Stackoverflow Member CDP1802 possible to tag, modify the code as per the dict vlaue. Need small support if childnodes has the same value in one attribute want to write it in same cell .

Ex : Object 1 and Object 2 has LightingConditions, I want to write it same cell defined with ";" . And in XMl first line need to be skipped or removed. Each xml value needs to be write in one column, next xml file to next column

Eg :

<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>
</Tag>

Code:

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

In principle this code builds a list of all nodes and uses a dictionary to check which of the wanted ones exist.

UPDATED to ignore 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