VBA отображает XML с иерархией в ячейках

Отображение иерархии XML в столбцах

Поскольку @Pat требует списка, где

• имена узлов появляются в последующих столбцах в порядке их уровня иерархии,
• текстовые значения узла в следующем правом столбце и
• определения атрибутов в последнем столбце,

Я добавил перечисление сверху, чтобы упростить ссылки на столбцы, близкие к OP (предполагается, что он включает узел верхнего уровня ~~>, то есть уровень 0 тоже).

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

Основная процедура

• [1] запускает рекурсивный вызов для сбора строк узлов/атрибутов в массиве
• [2] записывает результаты в заданный целевой диапазон.

В этом примере я предпочел .Load файл примера вместо .LoadXML строки содержимого, чтобы пользователи могли копировать решение, копируя XML-содержимое OP непосредственно в тестовую папку, а не создавая эту строку с помощью кода VBA окольным путем.

Кроме того, XML загружается с помощью поздней привязки, чтобы обеспечить простую загрузку для всех пользователей; конечно, это можно легко изменить на раннее связывание.

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

Рекурсивная функция 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

Функция помощи 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