... natürlich etwas umgeschrieben.
Luke, so zielstrebig wie Du bist - das kenne ich - das schätze ich - möchte Ich unterstützen. Behalte den Elan, aber beginne Deine Ziele durch Eigenleistung zu erreichen. Wenn es VBA dazu braucht, dann fang an zu lesen.
In diesem Sinner:
Folgendes schreibst Du in eine neue XLSM-Mappe; in ein allgemeines Modul. In demselben Ordner befinden sich Deine einzulesenden XML-Dateien.
Wenn Du das hast -> main() ausführen:
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")
'jede XML im selben Ordner wie diese XLSM einlesen und verarbeiten
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
'LateBindeing Objektreferenz
Set xmlDoc = CreateObject(class:="MSXML2.DomDocument")
'Minimale Fehlerbehandlung
On Error GoTo FinishErr
'neues Arbeitsblatt für XML-Import benennen
Set wks = ThisWorkbook.Worksheets.Add
wks.Name = "ImportXML"
'XML parsen/laden
Call xmlDoc.Load(sXmlPfad)
xmlDoc.validateOnParse = True
xmlDoc.setProperty "SelectionLanguage", "XPath"
'arrString für Node-Collection
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"
'durch Nodes schleifen und die Werte im neuen Arbeitsblatt hinterlegen
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
'Überschriften im neuen Arbeitsblatt nach http://www.vba-forum.de/forum/View.aspx?ziel=59350-es_muss_nicht_VBA_sein
Call setÜberschrift(wks)
FinishErr:
Select Case Err.Number
Case 1004 'Falls Arbeitsblattname schon vorhanden, wks.name = Import + Rnd()
wks.Name = "ImportXML" & wks.Name
Resume Next
Case Else
'Debug.Print Err.Number; Err.Description
End Select
'Objektreferenzen entlassen
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
|