VBA 显示 XML 与单元格中的层次结构

Question

I am trying to format the below XML to print in the same hierarchical way it appears. Parent node in the first cell, in next row, second column first child and its attribute if any and its child nodes in following rows. Here is my XML:

<ResponseEnvelope xmlns="http://www.nwabcdfdfd.com/messagin" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
   <ResponseHeader>
      <RequestId>directv_99e0857d-abf3-461c-913e-3ab59c6b5ef6</RequestId>
      <ResponseId>1162969</ResponseId>
      <MessageVersion>1.10</MessageVersion>
      <RequestTimestamp>2013-02-12T17:26:28.172Z</RequestTimestamp>
      <ResponseTimestamp>2013-02-12T17:26:50.409Z</ResponseTimestamp>
      <SenderId>CarePortal2</SenderId>
      <ProgramName />
      <TestProdFlag>P</TestProdFlag>
      <ResultCode>9</ResultCode>
      <Locale>en_US</Locale>      
     <Error>
        <ErrorCode>9</ErrorCode>
        <ErrorNumber>90001</ErrorNumber>
        <ErrorMessage>System error occurred</ErrorMessage>
        <ErrorFieldId />
     </Error>      
   </ResponseHeader>
   <ResponseBody xsi:type="CPSingleSignOnResponse">
      <PortalUserID>45497</PortalUserID>
      <PartyID>1858186</PartyID>
      <WarrantyItemName>DTV ABC WOLE HE P</WarrantyItemName>
      <WarrantyInventoryItemId>138677</WarrantyInventoryItemId>
      <ClientWarrantySku>202</ClientWarrantySku>          
      <Customer type="primary">
         <PartyId>185812386</PartyId>
         <Salutation />
         <FirstName>XXXX</FirstName>
         <LastName>Tanna</LastName>         
            <Address type="current">
               <PartySiteId>3617490</PartySiteId>
               <Type>BILTO</Type>
               <Address1>CASCADES</Address1>
               <Address2>202</Address2>
               <Address3>RIDGE HEAVEN</Address3>
               <Address4 />
               <City>STERLING</City>
               <State>VA</State>
               <PostalCode>20165</PostalCode>
               <County>LOUDOUN</County>
               <Province />
               <Country>US</Country>
               <Urbanization />
               <AddressStyle>US</AddressStyle>
            </Address>                          
      </Customer>
   </ResponseBody>
</ResponseEnvelope>

This is the code i developed to print in just next rows and adjacent cells. But what i need is as in the attached image Code:

Sub Write_XML_To_Cells(ByVal Response_Data As String)
    Dim rXml        As MSXML2.DOMDocument60
    Set rXml = New MSXML2.DOMDocument60
    rXml.LoadXML Response_Data
    
    Dim i           As Integer
    Dim Start_Col As Integer
    i = 3
    Set oParentNode = rXml.DocumentElement
    Call List_ChildNodes(oParentNode, i)
End Sub
Sub List_ChildNodes(oParentNode, i)
    Dim X_sheet     As Worksheet
    Set X_sheet = Sheets("DTAppData | Auditchecklist")
    Dim Node_Set As Boolean
    For Each oChildNode In oParentNode.ChildNodes
        Node_Set = False
        Err.Clear
        On Error Resume Next
        
        If Not ((oChildNode.BaseName & vbNullString) = vbNullString) Then
            Node_Set = True
            If Not IsNull(oChildNode.Attributes) And oChildNode.Attributes.Length > 0 Then
                X_sheet.Cells(i, 1) = oChildNode.BaseName
                For Each Atr In oChildNode.Attributes
                   'Attributes in concatenation 
                    X_sheet.Cells(i, 2) = X_sheet.Cells(i, 2) & " " & Atr.XML
                Next
                    i = i + 1
            Else
                 X_sheet.Cells(i, 1) = oChildNode.BaseName
                 i = i + 1
            End If
         End If
         
        If oChildNode.ChildNodes.Length > 1 Then
            For Each oChildNode1 In oChildNode.ChildNodes
                Call List_ChildNodes(oChildNode1, i)
            Next
        Else
            If ((oChildNode.tagName & vbNullString) = vbNullString) Then
                X_sheet.Cells(i, 1) = oChildNode.ParentNode.nodeName
                X_sheet.Cells(i, 2) = oChildNode.ParentNode.Text
                i = i + 1
            Else
                If Not ((oChildNode.Text & vbNullString) = vbNullString) Then
                    X_sheet.Cells(i, 1) = oChildNode.tagName
                    X_sheet.Cells(i, 2) = oChildNode.Text
                    i = i + 1
                Else
                    X_sheet.Cells(i, 1) = oChildNode.tagName
                    i = i + 1
                End If
            End If
        End If
    Next
End Sub

Here is what expected output

Answer 1

Display XML hierarchy in columns

As @Pat requires a listing where

• node names occur in subsequent columns following the order of their hierarchy level ,
• textual node values in the following right column and
• attribute definitions in the last column,

I added an enumeration on top to facilitate column references close to OP (assumption is made to include the top level node ~~> ie Level 0, too).

Option Explicit                     ' declaration head of code module
Public Enum col
    LEVELS = 4                      ' << maximum count of hierarchy levels
    val1
    val2
End Enum

The main procedure

• [1] starts a recursive call to collect node/attribute strings within an array
• [2] writes the results to a given target range.

In this example I preferred to .Load an example file instead of a .LoadXML content string to allow users to replicate the solution by copying OP's XML content directly into a test folder rather than by creating this string via VBA code in a roundabout way.

Furthermore the xml is loades via late binding to allow a simple load for all users; of course this could be changed easily to early binding .

Sub DisplayXML()

    Dim xFileName As String
    xFileName = ThisWorkbook.Path & "\xml\hierarchy.xml"  ' << change to your needs
    
    Dim xDoc As Object
    Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")

    xDoc.Async = False
    xDoc.ValidateOnParse = False
    Debug.Print xDoc.XML

    If xDoc.Load(xFileName) Then
        ' [1] write xml info to array with exact or assumed items count
        Dim v As Variant: ReDim v(1 To xDoc.SelectNodes("//*").Length, 1 To col.LEVELS + 3)
        '     start call of recursive function
        listChildNodes xDoc.DocumentElement, v ' call help function listChildNodes

        ' [2] write results to target sheet                 ' << change to your sheet name
        With ThisWorkbook.Worksheets("DTAppData | Auditchecklist")
            Dim r As Long, c As Long
            r = UBound(v): c = UBound(v, 2)
            .Range("A1").Resize(r, c) = ""                  ' clear result range
            .Range("A1").Resize(1, c) = Split("Level 0, Level 1,Level 2, Level 3, Level 4,Value 1 (Node),Value 2 (Attribute)", ",") ' titles
            .Range("A2").Resize(r, c) = v ' get  2-dim info array
        End With
    Else
        MsgBox "Load Error " & xFileName
    End If
    Set xDoc = Nothing
End Sub

Recursive function listChildNodes()

Function listChildNodes(oCurrNode As Object, _
                        ByRef v As Variant, _
                        Optional ByRef i As Long = 1, _
                        Optional nLvl As Long = 0 _
                        ) As Boolean
' Purpose: assign the complete node structure with contents to a 1-based 2-dim array
' Author:  https://stackoverflow.com/users/6460297/t-m
' Date:    2018-08-19
' Note: Late binding XML doesn't allow the use of IXMLDOMNodeType enumeration constants
'       (1 ... NODE_ELEMENT, 2 ... NODE_ATTRIBUTE, 3 ... NODE_TEXT etc.)
' Escape
  If oCurrNode Is Nothing Then Exit Function
  If i < 1 Then i = 1                                       ' one based items Counter
' Edit 2018-08-20 - Automatic increase of array size if needed
  If i >= UBound(v) Then                                    ' change array size if needed
     Dim tmp As Variant
     tmp = Application.Transpose(v)                         ' change rows to columns
     ReDim Preserve tmp(1 To col.LEVELS + 3, 1 To UBound(v) + 1000)    ' increase row numbers
     v = Application.Transpose(tmp)                         ' transpose back
     Erase tmp
  End If

' Declare variables
  Dim oChildNode As Object                                  ' late bound node object
  Dim bDisplay   As Boolean
' ---------------------------------------------------------------------
' A. It's nothing but a TextNode (i.e. a parent node's firstChild!)
' ---------------------------------------------------------------------
If (oCurrNode.NodeType = 3) Then                            ' 3 ... NODE_TEXT
  ' display pure text content (NODE_TEXT) of parent elements
    v(i, col.val1 + 1) = oCurrNode.Text                     ' nodeValue of text node
  ' return
    listChildNodes = True
ElseIf oCurrNode.NodeType = 1 Then                          ' 1 ... NODE_ELEMENT
   ' --------------------------------------------------------------
   ' B.1 NODE_ELEMENT WITHOUT text node immediately below,
   '     a) e.g. <Details> followed by node element <NAME>,
   '        (i.e. FirstChild.NodeType must not be of type NODE_TEXT = 3)
   '     b) e.g. <College> node element without any child node
   '     Note: a text content (NODE_TEXT) actually is a child node(!) to an element node
   '           (see section A. getting the FirstChild of a NODE_ELEMENT)
   ' --------------------------------------------------------------
   ' a) display parent elements of other element nodes
     If oCurrNode.HasChildNodes Then
         If Not oCurrNode.FirstChild.NodeType = 3 Then      ' <>3 ... not a NODE_TEXT
            bDisplay = True
         End If
   ' b) always display empty node elements
     Else                                                   ' empty NODE_ELEMENT
            bDisplay = True
     End If
     If bDisplay Then
            v(i, nLvl + 1) = oCurrNode.nodename
            v(i, col.val2 + 1) = getAtts(oCurrNode)
            i = i + 1
     End If

   ' --------------------------------------------------------------
   ' B.2 check child nodes
   ' --------------------------------------------------------------
     For Each oChildNode In oCurrNode.ChildNodes
      ' ~~~~~~~~~~~~~~~~~
      ' recursive call <<
      ' ~~~~~~~~~~~~~~~~~
        bDisplay = listChildNodes(oChildNode, v, i, nLvl + 1)

        If bDisplay Then
            v(i, nLvl + 1) = oCurrNode.nodename
            v(i, col.val2 + 1) = getAtts(oCurrNode)
            i = i + 1
        End If
     Next oChildNode
   ' return
     listChildNodes = False

Else    ' just to demonstrate the use of other xml types as e.g. <!-- comments -->
     If oCurrNode.NodeType = 8 Then   ' 8 ... NODE_COMMENT
        v(i, nLvl + 1) = "<!-- " & oCurrNode.NodeValue & "-->"
        i = i + 1
     End If
   ' return
     listChildNodes = False
End If

End Function

Help function getAtts()

Function getAtts(ByRef node As Object) As String
' Purpose: return attribute(s) string, e.g. 'type="primary"]'
' Note:    called by above function listChildNodes()
' Author:  https://stackoverflow.com/users/6460297/t-m
  Dim sAtts as String, ii As Long
  If node.Attributes.Length > 0 Then
      ii = 0: sAtts = ""
      For ii = 0 To node.Attributes.Length - 1
        sAtts = sAtts & "" & node.Attributes.Item(ii).nodename & "=""" & node.Attributes.Item(ii).NodeValue & """ "
      Next ii
  End If
' return
  getAtts = sAtts
End Function