I hinzugefügt selektiv publisher, preorder und cover Eigenschaften des typischen XML-Code, so dass der Code für den Test ist wie folgt:
<catalog>
<book id="bk101">
<author>Gambardella, Matthew</author>
<title>XML Developer's Guide</title>
<genre>Computer</genre>
<price>44.95</price>
<publish_date>2000-10-01</publish_date>
<description>An in-depth look at creating applications with XML.</description>
</book>
<book id="bk102">
<author>Ralls, Kim</author>
<title>Midnight Rain</title>
<genre>Fantasy</genre>
<price>5.95</price>
<preorder>2.49</preorder>
<publish_date>2000-12-16</publish_date>
<description>A former architect battles corporate zombies, an evil sorceress, and her own childhood to become queen of the world.</description>
</book>
<book id="bk103">
<author>Corets, Eva</author>
<title>Maeve Ascendant</title>
<genre>Fantasy</genre>
<price>5.95</price>
<preorder>1.99</preorder>
<publish_date>2000-11-17</publish_date>
<cover>case binding</cover>
<description>After the collapse of a nanotechnology society in England, the young survivors lay the foundation for a new society.</description>
</book>
<book id="bk104">
<publisher>Pearson</publisher>
<author>Corets, Eva</author>
<title>Oberon's Legacy</title>
<genre>Fantasy</genre>
<price>5.95</price>
<publish_date>2001-03-10</publish_date>
<description>In post-apocalypse England, the mysterious agent known only as Oberon helps to create a new life for the inhabitants of London. Sequel to Maeve Ascendant.</description>
</book>
</catalog>
Hier ist ein Beispiel ist eine der möglichen Lösungen zeigt, die eine verarbeiten erlaubt tabellenartige Daten, die als XML gespeichert sind und ein 2d-Array abrufen, das die Tabelle mit dem Header darstellt. Es verarbeitet Elemente gemäß dem bereitgestellten XPath-Selektor, betrachtet Element-Childnodes als Eigenschaften, extrahiert Eigenschaftennamen und -werte und lokalisiert die Eigenschaften in den richtigen Spalten.
Option Explicit
Sub Test()
Dim strBooksXML As String
Dim arrBooks() As Variant
' get certain XML code
strBooksXML = MyXMLData
' pass XML code and XPath selector to retrieve table-form array
arrBooks = ConvertXMLToArray(strBooksXML, "//catalog/book")
' resulting array output
Output Sheets(1), arrBooks
End Sub
Function ConvertXMLToArray(strXML As String, strItemSelector As String) As Variant()
Dim objDOMDocument As Object
Dim objPrpIdx As Object
Dim objPrpVal As Object
Dim lngItemNumber As Long
Dim colItems As Object
Dim objItem As Variant
Dim objItemProperty As Variant
Dim strPrev As String
Dim strName As String
Dim lngIndex As Long
Dim arrItems() As Variant
Dim varPrpName As Variant
Dim varItemIndex As Variant
Set objDOMDocument = CreateObject("MSXML2.DOMDocument")
If Not objDOMDocument.LoadXML(strXML) Then
Err.Raise objDOMDocument.parseError.ErrorCode, , objDOMDocument.parseError.reason
End If
Set objPrpIdx = CreateObject("Scripting.Dictionary") ' dictionary of property order indexes
Set objPrpVal = CreateObject("Scripting.Dictionary") ' dictionary of property values
lngItemNumber = 1
Set colItems = objDOMDocument.SelectNodes(strItemSelector)
For Each objItem In colItems
strPrev = "" ' previous processed property name
For Each objItemProperty In objItem.ChildNodes
strName = objItemProperty.BaseName ' name of the property being processed
If Not objPrpIdx.Exists(strName) Then ' no such property yet
If strPrev = "" Then ' the property is the first
lngIndex = 0
Else ' the property placed after another
lngIndex = objPrpIdx(strPrev) + 1
End If
' increase all indexes that are greater or equal to processing property assigned index
' i. e. shift existing properties to insert new one
For Each varPrpName In objPrpIdx
If objPrpIdx(varPrpName) >= lngIndex Then objPrpIdx(varPrpName) = objPrpIdx(varPrpName) + 1
Next
' add new property name to dictionary of property order indexes with assigned index
objPrpIdx(strName) = lngIndex
' add new property name to dictionary of property values, instantiate subdictionary of values
Set objPrpVal(strName) = CreateObject("Scripting.Dictionary")
End If
objPrpVal(strName)(lngItemNumber) = objItemProperty.Text ' put property value with item index to the subdictionary
strPrev = strName ' reassign previous property name
Next
lngItemNumber = lngItemNumber + 1
Next
' rebuild dictionaries into 2d array for further output to worksheet
ReDim arrItems(lngItemNumber - 1, objPrpIdx.Count - 1)
For Each varPrpName In objPrpIdx ' process each
arrItems(0, objPrpIdx(varPrpName)) = varPrpName ' put property name to header
For Each varItemIndex In objPrpVal(varPrpName) ' process each item having the property
arrItems(varItemIndex, objPrpIdx(varPrpName)) = objPrpVal(varPrpName)(varItemIndex)
Next
Next
ConvertXMLToArray = arrItems
End Function
Sub Output(objSheet As Worksheet, arrCells() As Variant)
With objSheet
.Select
.Cells.Delete
With .Range(.Cells(1, 1), Cells(UBound(arrCells, 1) + 1, UBound(arrCells, 2) + 1))
.NumberFormat = "@"
.Value = arrCells
End With
.Columns.AutoFit
End With
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
End Sub
Function MyXMLData()
Dim strXML
strXML = _
"<catalog>"
strXML = strXML & _
"<book id=""bk101"">" & _
"<author>Gambardella, Matthew</author>" & _
"<title>XML Developer's Guide</title>" & _
"<genre>Computer</genre>" & _
"<price>44.95</price>" & _
"<publish_date>2000-10-01</publish_date>" & _
"<description>An in-depth look at creating applications " & _
"with XML.</description>" & _
"</book>"
strXML = strXML & _
"<book id=""bk102"">" & _
"<author>Ralls, Kim</author>" & _
"<title>Midnight Rain</title>" & _
"<genre>Fantasy</genre>" & _
"<price>5.95</price>" & _
"<preorder>2.49</preorder>" & _
"<publish_date>2000-12-16</publish_date>" & _
"<description>A former architect battles corporate zombies, " & _
"an evil sorceress, and her own childhood to become queen " & _
"of the world.</description>" & _
"</book>"
strXML = strXML & _
"<book id=""bk103"">" & _
"<author>Corets, Eva</author>" & _
"<title>Maeve Ascendant</title>" & _
"<genre>Fantasy</genre>" & _
"<price>5.95</price>" & _
"<preorder>1.99</preorder>" & _
"<publish_date>2000-11-17</publish_date>" & _
"<cover>case binding</cover>" & _
"<description>After the collapse of a nanotechnology " & _
"society in England, the young survivors lay the " & _
"foundation for a new society.</description>" & _
"</book>"
strXML = strXML & _
"<book id=""bk104"">" & _
"<publisher>Pearson</publisher>" & _
"<author>Corets, Eva</author>" & _
"<title>Oberon's Legacy</title>" & _
"<genre>Fantasy</genre>" & _
"<price>5.95</price>" & _
"<publish_date>2001-03-10</publish_date>" & _
"<description>In post-apocalypse England, the mysterious " & _
"agent known only as Oberon helps to create a new life " & _
"for the inhabitants of London. Sequel to Maeve " & _
"Ascendant.</description>" & _
"</book>"
strXML = strXML & _
"</catalog>"
MyXMLData = strXML
End Function
Die resultierende Ausgabe ist wie für mich folgt:
Dieser Ansatz Wörterbücher verwendet, die ganz für große XML-Daten langsam sein kann, für diesen Fall besser, den Code zu überarbeiten Arrays zu verwenden, anstelle von Wörterbüchern, like here with JSON processing.
Mein Vorschlag ist es, zuerst alle XML-Knoten der obersten Ebene ('book'-Knoten) durchzugehen und ein Verzeichnis aller möglichen Kindknoten zu erstellen - im Grunde genommen ein Super-Set von Knoten, die zu den Spalten Ihrer Tabelle werden. Beginnen Sie dann Ihren zweiten Durchlauf durch die Liste und fügen Sie die Daten für jeden der Buchknoten den entsprechenden Spalten hinzu. Sie können dies in einem einzigen Schritt tun, indem Sie alle neu gefundenen untergeordneten Knoten als neue Spalten rechts neben den vorhandenen Daten hinzufügen. – PeterT
Hallo Peter, ja das ist genau, was ich mir vorstelle. Das Hauptproblem ist, dass ich nicht weiß, wie man über Buchknoten läuft, da ich die korrekte Syntax der proprietären Selektoren nicht kenne, wie man mit den XML-Objekten mit VBA usw. umgeht. Und ich konnte diese Informationen nicht online finden. – heikeke
Werfen Sie einen Blick auf [diese Antwort] (http://stackoverflow.com/a/20022152/4717755). Es macht genau das, was Sie wollen. – PeterT