将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、客户id和订单id不会导出到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

下面使用的是regex，只有每次将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

编辑：轻微更新到数组的输出以写入范围

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