Option Explicit
Const m_sVehicleIdentificationNumber As String = "VehicleIdentificationNumber"
Const m_sTypeApprovalNumber As String = "TypeApprovalNumber"
Const m_sTechnicallyPermMassAxle As String = "TechnicallyPermMassAxle"
Const m_sTechPermMassAxleGroup As String = "TechPermMassAxleGroup"
Sub main()
Dim sXMLFileName As String
sXMLFileName = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xml")
While sXMLFileName <> ""
Call XmlZugriffViaXPathAufCollection(ThisWorkbook.Path & Application.PathSeparator & sXMLFileName)
sXMLFileName = Dir()
Wend
End Sub
Sub XmlZugriffViaXPathAufCollection(ByVal sXmlPfad As String)
Dim wks As Excel.Worksheet
Dim arr(3) As String
Dim xmlDoc As Object
Dim xmlNode As Object
Dim i As Byte
Set xmlDoc = CreateObject(class:="MSXML2.DomDocument")
On Error GoTo FinishErr
Set wks = ThisWorkbook.Worksheets.Add
wks.Name = "ImportXML"
Call xmlDoc.Load(sXmlPfad)
xmlDoc.validateOnParse = True
xmlDoc.setProperty "SelectionLanguage", "XPath"
arr(0) = "/InitialVehicleInformation/Body/DataGroup/VehicleIdentificationNumber"
arr(1) = "/InitialVehicleInformation/Body/DataGroup/TypeApprovalNumber"
arr(2) = "/InitialVehicleInformation/Body/DataGroup/AxleTable/AxleGroup/TechnicallyPermMassAxle"
arr(3) = "/InitialVehicleInformation/Body/DataGroup/AxleGroupTable/AxleGroupGroup/TechPermMassAxleGroup"
For i = LBound(arr) To UBound(arr)
For Each xmlNode In xmlDoc.SelectNodes(arr(i))
Debug.Print xmlNode.nodeName
Select Case xmlNode.nodeName
Case Is = m_sVehicleIdentificationNumber
Call setValueInWorksheet(wks, m_sVehicleIdentificationNumber, xmlNode.Text)
Case Is = m_sTypeApprovalNumber
Call setValueInWorksheet(wks, m_sTypeApprovalNumber, xmlNode.Text)
Case Is = m_sTechnicallyPermMassAxle
Call setValueInWorksheet(wks, m_sTechnicallyPermMassAxle, xmlNode.Text)
Case Is = m_sTechPermMassAxleGroup
Call setValueInWorksheet(wks, m_sTechPermMassAxleGroup, xmlNode.Text)
Case Else
End Select
Next
Next i
Call setÜberschrift(wks)
FinishErr:
Select Case Err.Number
Case 1004
wks.Name = "ImportXML" & wks.Name
Resume Next
Case Else
End Select
Set xmlNode = Nothing: Set xmlDoc = Nothing: Set wks = Nothing
End Sub
Sub setValueInWorksheet(wks As Excel.Worksheet, sNodeName As String, sWriteValue As String)
With wks
Select Case sNodeName
Case Is = m_sVehicleIdentificationNumber
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = sWriteValue
Case Is = m_sTypeApprovalNumber
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Value = sWriteValue
Case Is = m_sTechnicallyPermMassAxle
.Cells(.Rows.Count, 3).End(xlUp).Offset(1).Value = sWriteValue
Case Is = m_sTechPermMassAxleGroup
.Cells(.Rows.Count, 4).End(xlUp).Offset(1).Value = sWriteValue
End Select
End With
End Sub
Sub setÜberschrift(wks As Excel.Worksheet)
With wks
.Cells(1, 1).Value = m_sVehicleIdentificationNumber
.Cells(1, 2).Value = m_sTypeApprovalNumber
.Cells(1, 3).Value = m_sTechnicallyPermMassAxle
.Cells(1, 4).Value = m_sTechPermMassAxleGroup
End With
End Sub