Makro:Aus einer XML-Datei eine Tabelle machen

Aus XIMES

CODE für Umwandlung von XML in eine Tabelle

 Option Explicit
 Public i As Long
 Public str As String
 
 ' Wandelt eine XML Datei, die in ein Blatt kopiert wurde in Liste mit Spaltenköpfen um
 ' ACHTUNG Es wird maximal eine Zeile übertragen. Werte, die über mehrere Zeile gehen,werden in dieser Version ignoriert)
 ' ZB WIRD FOLGENDES ...
 '<report>
 ' <columns>
 '  <column>Name</column>
 '  <column>type</column>
 '  <column>ID</column>
 ' </columns>
 ' <rows>
 '  <row>
 '   <c1>System</c1>
 '   <c2>String</c2>
 '   <c3>35</c3>
 '  </row>
 ' ..
 ' UMGEWANDELT IN
 ' Name    Type    ID
 ' System  String  35
 ' ...
 
 Sub Transform()
 Dim co As Long
 Dim von As Range
 Dim nach As Range
 Dim ze As Long
 Dim Leerzeilen As Integer
 Dim found As Boolean
 Dim j As Integer
 
 Set von = ActiveWorkbook.ActiveSheet.Cells
 
 
 Set nach = ActiveWorkbook.Worksheets("Nach").Cells 'XXX Hier umbenennen des Namen des Blattes wo es hinsoll
 
 nach.Cells.ClearContents
 co = 1
 ze = 1
 i = 1
 str = von(1, 1)
 Leerzeilen = 0
 
 While Leerzeilen <= 3 And i <= 65536 ' Abbruchbedingung Leerzeile und Zahl möglicher Zeilen
 
   If Len(str) = 0 Then
       found = False
       ' ZT kommen beim kopieren Spalten weiter nach rechts zum Liegen, das wird hier geprüft, damit es nicht Leerzeile ist
       For j = 2 To 10
           If von(i, j) <> "" Then found = True
       Next
       If found Then Leerzeilen = 0 Else Leerzeilen = Leerzeilen + 1
   Else
       Leerzeilen = 0
       
       'ZT wird falsch in EXCEL kopiert
       'Falls mehrere werte in einer Zelle gelandet sind, wird hier gestoppt
       'Vermutlich ist es dann besser von File her einzulesen oder das Stop zu deaktiviern
       If bis() > 0 Then
         If InStr(bis() + 2, str, "<") > 0 Then 
                Stop
         End if 
       End If
       
       'Aufbau der Zeilenüberschriften
       If InStr(str, "column>") > 0 Then
           ' Einfügen der Spaltenköpfe
           nach.Cells(1, co) = wert()
           co = co + 1
       ElseIf InStr(str, "columns>") > 0 Then
           'ignorieren
       ElseIf InStr(str, "<row>") > 0 Then
           'Neue Zeile im Ergebnisblatt
           If co > 1 Then
             ze = ze + 1
             co = 1
           End If
       ElseIf InStr(str, "<c") = 0 And InStr(str, "&") > 0 Then
           'Ignorieren von Folgezeilen
           
       ElseIf InStr(str, "<c") > 0 Then
           'Übertragen der Werte
           nach.Cells(ze, co) = wert()
           co = co + 1
       End If
    End If
    i = i + 1
    str = von(i, 1)
     
 Wend
 
 End Sub
 
 
 Function starte() As Integer
     starte = InStr(str, ">") + 1
 End Function
 
 
 Function bis() As Integer
     bis = InStr(starte(), str, "<") - 1
 End Function
 
 
 Function wert() As String
   If str <> "" Then
       If bis() > 0 Then
         wert = Mid(str, starte(), bis() - starte() + 1)
       Else
         If Len(str) > starte() Then
           wert = Mid(str, starte(), Len(str) - starte())
         Else
           wert = ""
         End If
       End If
   Else
       wert = ""
   End If
 End Function