Reputation: 51
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
Upvotes: 1
Views: 281
Reputation: 16392
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
Upvotes: 1