|
Möglichkeiten gibt's da viele:
Option Explicit
Sub Test()
Dim r As Object
Dim vnt As Variant
Dim i As Long
Set r = CreateObject("VBScript.RegExp")
r.IgnoreCase = True
r.Global = False
r.MultiLine = False
'XML-Dateipfad
vnt = "G:\data\127020.xml"
'Einlesen der XML-Datei
i = FreeFile
Open vnt For Input As #i
vnt = StrConv(InputB(FileLen(vnt), #i), vbUnicode)
Close #i
'entfernen von Wagenrücklauf-/Zeilenvorschub entfernen
While InStr(1, vnt, vbCr) > 0 Or InStr(1, vnt, vbLf) > 0
vnt = Replace$(Replace$(vnt, vbCr, ""), vbLf, "")
Wend
'versuche Datenbereich zu lesen
r.Pattern = "<data>(.*)</data>"
Set vnt = r.Execute(vnt)
If vnt.Count > 0 Then
'Daten zwischen Tags in Array umwandeln (Trennzeichen := Komma)
vnt = Split(vnt(0).SubMatches(0), ",")
'ersten drei Daten werden ignoriert
'sollten mehr vorhanden sein,
'dann gibt es was zu tun...
If UBound(vnt) > 3 Then
'Daten nach oben verschieben und dabei Information(en) filtern
'z.B. 1x23 -> 23
For i = 3 To UBound(vnt)
vnt(i - 3) = Right$(vnt(i), Len(vnt(i)) - InStr(1, vnt(i), "x"))
If i > UBound(vnt) - 3 Then vnt(i) = "" 'letzten drei sind leer
Next
'Daten - bis auf die letzten drei - ausgeben
With Worksheets("Tabelle1").Range("A1").Resize(UBound(vnt) - 3)
.NumberFormat = "@" 'Zellenformat: Text
.Value = WorksheetFunction.Transpose(vnt)
End With
End If
End If
End Sub
|