將XML文檔中的數據解析爲Excel工作表

Question

<?xml version="1.0" encoding="UTF-8"?> 
<xa:MeContext id="ABCe0552553"> 
    <xa:Data id="ABCe05525531" /> 
    <xa:Data id="1" /> 
    <CustID>Cust1234</CustID> 
    <Name>Smith</Name> 
    <City>New York</City> 
    <Orders> 
    <order Orderid="101"> 
     <Product>MP3 Player</Product> 
    </order> 
    <order Orderid="102"> 
     <Product>Radio</Product> 
    </order> 
    </Orders> 
</xa:MeContext> 

此格式良好的XML文檔使用MS VBA代碼提供給Excel 2007。我成功地使用DOMDocument和IXMLDOMElement來成功導入名稱，城市和產品 。
但是，xa:MeContext id,vsData1 id,VsData2 id,CustID和order Orderid號碼不會導出到Excel工作表。

每個Excel中的行與從XML文檔數據填充以下標題：

MeContextID--vsData1--VsData2--CustID--Name--City--OrderID--Product--OrderID--Product 

Answer 1

下面是兩種方法，以輸出你需要的領域。請注意，您發佈的XML不包含名稱空間「xa：」的標題定義，因此不是完全形成的XML。我已經在示例中刪除了它們，因此MSXML2.DOMDocument不會引發解析錯誤。

Option Explicit 
Sub XMLMethod() 
Dim XMLString As String 
Dim XMLDoc As Object 
Dim boolValue As Boolean 
Dim xmlDocEl As Object 
Dim xMeContext As Object 
Dim xChild As Object 
Dim xorder As Object 


    XMLString = Sheet1.Range("A1").Value 

    'Remove xa: in this example 
    'reason : "Reference to undeclared namespace prefix: 'xa'." 
    'Shouldn't need to do this if full XML is well formed containing correct namespace 
    XMLString = Replace(XMLString, "xa:", vbNullString) 

    Set XMLDoc = CreateObject("MSXML2.DOMDocument") 
    'XMLDoc.setProperty "SelectionNamespaces", "xa:" 

     'XMLDoc.Load = "C:\Users\ooo\Desktop\test.xml" 'load from file 
    boolValue = XMLDoc.LoadXML(XMLString) 'load from string 

    Set xmlDocEl = XMLDoc.DocumentElement 
    Set xMeContext = xmlDocEl.SelectSingleNode("//MeContext") 
     Debug.Print Split(xMeContext.XML, """")(1) 
    For Each xChild In xmlDocEl.ChildNodes 

     If xChild.NodeName = "Orders" Then 
      For Each xorder In xChild.ChildNodes 
       Debug.Print Split(xorder.XML, """")(1) 
       Debug.Print xorder.Text 
      Next xorder 

     ElseIf xChild.Text = "" Then 
      Debug.Print Split(xChild.XML, """")(1) 
     Else 
      Debug.Print xChild.Text 
     End If 


    Next xChild 

    'Output: 
    'ABCe0552553 
    'ABCe05525531 
    '1 
    'Cust1234 
    'Smith 
    'New York 
    '101 
    'MP3 Player 
    '102 
    'Radio 


End Sub 

而下面使用正則表達式，它只有在XML每次都固定爲您的示例時才真正有用。一般情況下，建議不要對XML進行解析，除非您希望加快可靠性。

Option Explicit 

Sub RegexMethod() 
Dim XMLString As String 
Dim oRegex As Object 
Dim regexArr As Object 
Dim rItem As Object 

    'Assumes Sheet1.Range("A1").Value holds example XMLString 
    XMLString = Sheet1.Range("A1").Value 

    Set oRegex = CreateObject("vbscript.regexp") 
    With oRegex 
     .Global = True 
     .Pattern = "(id=""|>)(.+?)(""|</)" 
     Set regexArr = .Execute(XMLString) 

     'No lookbehind so replace unwanted chars 
     .Pattern = "(id=""|>|""|</)" 
     For Each rItem In regexArr 
      'Change Debug.Print to fill an array to write to Excel 
      Debug.Print .Replace(rItem, vbNullString) 
     Next rItem 
    End With 

    'Output: 
    'ABCe0552553 
    'ABCe05525531 
    '1 
    'Cust1234 
    'Smith 
    'New York 
    '101 
    'MP3 Player 
    '102 
    'Radio 


End Sub 

EDIT：輕微更新，以輸出到陣列，用於寫入的範圍

Option Explicit 

Sub RegexMethod() 
Dim XMLString As String 
Dim oRegex As Object 
Dim regexArr As Object 
Dim rItem As Object 
Dim writeArray(1 To 1, 1 To 10) As Variant 
Dim col As Long 

    'Assumes Sheet1.Range("A1").Value holds example XMLString 
    XMLString = Sheet1.Range("A1").Value 

    Set oRegex = CreateObject("vbscript.regexp") 
    With oRegex 
     .Global = True 
     .Pattern = "(id=""|>)(.+?)(""|</)" 
     Set regexArr = .Execute(XMLString) 

     'No lookbehind so replace unwanted chars 
     .Pattern = "(id=""|>|""|</)" 
     For Each rItem In regexArr 
      'Change Debug.Print to fill an array to write to Excel 
      Debug.Print .Replace(rItem, vbNullString) 

      col = col + 1 
      writeArray(1, col) = .Replace(rItem, vbNullString) 
     Next rItem 
    End With 

    Sheet1.Range("A5:J5").Value = writeArray 


End Sub 


Sub XMLMethod() 
Dim XMLString As String 
Dim XMLDoc As Object 
Dim boolValue As Boolean 
Dim xmlDocEl As Object 
Dim xMeContext As Object 
Dim xChild As Object 
Dim xorder As Object 
Dim writeArray(1 To 1, 1 To 10) As Variant 
Dim col As Long 


    XMLString = Sheet1.Range("A1").Value 

    'Remove xa: in this example 
    'reason : "Reference to undeclared namespace prefix: 'xa'." 
    'Shouldn't need to do this if full XML is well formed 
    XMLString = Replace(XMLString, "xa:", vbNullString) 

    Set XMLDoc = CreateObject("MSXML2.DOMDocument") 
    'XMLDoc.setProperty "SelectionNamespaces", "xa:" 

     'XMLDoc.Load = "C:\Users\ooo\Desktop\test.xml" 'load from file 
    boolValue = XMLDoc.LoadXML(XMLString) 'load from string 

    Set xmlDocEl = XMLDoc.DocumentElement 
    Set xMeContext = xmlDocEl.SelectSingleNode("//MeContext") 
     'Debug.Print Split(xMeContext.XML, """")(1) 
     col = col + 1 
     writeArray(1, col) = Split(xMeContext.XML, """")(1) 
    For Each xChild In xmlDocEl.ChildNodes 

     If xChild.NodeName = "Orders" Then 
      For Each xorder In xChild.ChildNodes 
       col = col + 1 
       'Debug.Print Split(xorder.XML, """")(1) 
       writeArray(1, col) = Split(xorder.XML, """")(1) 
       col = col + 1 
       'Debug.Print xorder.Text 
       writeArray(1, col) = xorder.Text 
      Next xorder 
     ElseIf xChild.Text = "" Then 
      col = col + 1 
      'Debug.Print Split(xChild.XML, """")(1) 
      writeArray(1, col) = Split(xChild.XML, """")(1) 
     Else 
      col = col + 1 
      'debug.Print xChild.Text 
      writeArray(1, col) = xChild.Text 
     End If 


    Next xChild 

    Sheet1.Range("A5:J5").Value = writeArray 


End Sub