Excel VBA – вложенные данные в XML-файле

Код ниже запишет необходимые данные в столбцы A и B активного листа, как показано на снимке экрана ниже. Обратите внимание: я исправил незакрытый тег в XML-файле, поэтому для тестирования используйте приведенный ниже тег. Кроме того, файл XML должен находиться в той же папке, что и файл Excel. Код написан в 64-разрядной версии Excel 2010 на 64-разрядной версии Win 11. (Столбец B должен быть отформатирован как Text, в противном случае Excel попытается записать данные как Date).

<Level1 Name = "Top">
    <Level2 Name = "First" id = "1-0">
        <Level3 Name = "First First" id = "1-1" />
        <Level3 Name = "Second First" id = "1-2" />
        <Level3 Name = "Third First" id = "1-3" />
    </Level2>
    <Level2 Name = "Second" id = "1-0">
        <Level3 Name = "First Second" id = "2-1" />
        <Level3 Name = "Second Second" id = "2-2" />
        <Level3 Name = "Third Second" id = "2-3" />
    </Level2>
</Level1>

Sub Test()
    Dim XDoc As Object, strURL As String
    Dim myList As Object, Num As Integer, i As Integer
    
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    XDoc.async = False
    XDoc.validateOnParse = False
    
    strURL = ThisWorkbook.Path & "/Test.xml"
    XDoc.Load strURL
     
    Set myList = XDoc.SelectNodes("//Level2/Level3")
        
    If myList.Length = 0 Then GoTo SafeExit:
    
    Num = myList.Length - 1
    
    For i = 0 To Num
        Cells(i + 1, 1) = myList(i).getAttribute("Name")
        Cells(i + 1, 2) = myList(i).getAttribute("id")
    Next
    
SafeExit:
    Set myList = Nothing
    Set XDoc = Nothing
End Sub

ПРИМЕЧАНИЕ:

Вместо следующей строки;

Set myList = XDoc.SelectNodes("//Level2/Level3")

вы также можете использовать это;

Set myList = XDoc.getElementsByTagname("Level3")

.

Если вам нужен вложенный уровень 3 для каждого уровня 2:

Sub Stuff()
    
    Dim oXMLFile As New MSXML2.DOMDocument60
    Dim L2Nodes As IXMLDOMNodeList, el2 As Object
    Dim L3Nodes As IXMLDOMNodeList, el3 As Object
    
    oXMLFile.async = False
    oXMLFile.validateOnParse = True
    oXMLFile.LoadXML [A4].Value
    Debug.Print oXMLFile.parseError.reason

    Set L2Nodes = oXMLFile.SelectNodes("//Level1/Level2")
    Debug.Print L2Nodes.Length
    
    For Each el2 In L2Nodes
        Debug.Print el2.getAttribute("Name")
        Set L3Nodes = el2.SelectNodes("Level3")'<< Get child Level3 nodes
        For Each el3 In L3Nodes
            Debug.Print , el3.getAttribute("id")
        Next el3
    Next
    
End Sub

Во-первых, у вас неправильный XML-код... Во-первых, тег Level2 не закрыт. Это должно выглядеть так:

<Level1 Name = "Top">
    <Level2 Name = "First" id = "1-0">
        <Level3 Name = "First First" id = "1-1" />
        <Level3 Name = "Second First" id = "1-2" />
        <Level3 Name = "Third First" id = "1-3" />
    </Level2>
    <Level2 Name = "Second" id = "1-0">
        <Level3 Name = "First Second" id = "2-1" />
        <Level3 Name = "Second Second" id = "2-2" />
        <Level3 Name = "Third Second" id = "2-3" />
    </Level2>
</Level1>

Полезно проверить правильность XML (в коде). Итак, было бы хорошо использовать .validateOnParse = True, а затем проверить, загружен ли (не) файл. Пожалуйста, протестируйте следующий адаптированный код:

Sub Stuff()
    Dim XMLFileName As String
    Dim oXMLFile As New MSXML2.DOMDocument60
    Dim XMLSNL1 As IXMLDOMNodeList
    Dim XMLSE1 As IXMLDOMElement
    Dim XMLSE2 As IXMLDOMElement
    Dim XMLSNL2 As IXMLDOMNodeList
    
    XMLFileName = ThisWorkbook.Path & "\TesteXML\TestLevels.xml" 'use here your file path (if extracted from a local file)
    If Dir(XMLFileName) = "" Then MsgBox "Wrong file full name...": Exit Sub 'for local file
    
    With oXMLFile
        .async = False
        .validateOnParse = True 'if offer the possibility to check that XML is correct
        If Not .Load(XMLFileName) Then 'if not loaded (being incorrect) show the parse error 
                                       'description and number
           Debug.Print .parseError.reason, .parseError.ErrorCode: Exit Sub 'exist if not parsed
        End If

        Set XMLSNL1 = .SelectNodes("//Level1/Level2") 'set only a node list (since only Levell3 exists)
    End With

    Debug.Print XMLSNL1.Item(0).ParentNode.BaseName   'Level1
    For Each XMLSE1 In XMLSNL1
        Debug.Print , XMLSE1.BaseName & ": " & XMLSE1.getAttribute("Name") 'level2
        Set XMLSNL2 = XMLSE1.SelectNodes("Level3")
        For Each XMLSE2 In XMLSNL2
            Debug.Print , , XMLSE2.BaseName & ": " & XMLSE2.getAttribute("Name") 'level3
            Debug.Print , , , "Level3 ID = " & XMLSE2.getAttribute("id")
        Next XMLSE2
    Next
End Sub

Альтернатива через FilterXML()

Поскольку Excel предлагает функцию «FilterXML()» с 2016 года, у меня возникло искушение использовать эту возможность, принимая во внимание некоторые ограничения, и продемонстрировать ее с помощью Range.Evaluation.

Вы должны знать, что VBA не предоставляет списки узлов в зависимости от введенного XPath, а скорее считывает реальные значения в виде двухмерного массива (при наличии нескольких совпадений).

а) Name атрибут Например, чтобы получить атрибуты Name, все, что вам нужно сделать, это ввести правильно сформированную строку XML и простое выражение XPath в следующую формулу: =FILTERXML(A4, "//Level3/@Name")

б) id атрибут Однако считывание значений значительно сложнее — в приведенном выше случае атрибуты id, такие как 1-1, которые Excel интерпретирует как дату или числовое значение. Здесь мне пришлось сначала временно изменить разделитель «-» через Replace(), а затем после прочтения FilterXML поставить его обратно, но на этот раз в виде текстового значения.

Предостережение: если вы хотите записать массивы обратно на лист, вам потребуется текстовое форматирование принимающего столбца, иначе вы снова получите (также) числовые значения (см. раздел d).

Sub EvalXMLFilter()
    Dim Pattern: Pattern = "FilterXML(A4,""//Level3/@"")"
    Dim expr As String
    With Sheet1                 ' << change as needed
    'a) get names
        Dim names
        expr = Replace(Pattern, "@", "@Name")
        '~~>FILTERXML(A4,"//Level3/@Name")
        names = .Evaluate(expr)
    'b) get ids
        Dim ids
        expr = Replace(Pattern, "FilterXML(A4,", "Substitute(FILTERXML(Substitute(A4,""-"",""$""),")
        expr = Replace(expr, "@", "@id" & """),""$"",""-")
        '~~>SUBSTITUTE(FILTERXML(SUBSTITUTE(A4,"-","$"),"//Level3/@id"),"$","-")
        ids = .Evaluate(expr)
    'c) optional - write to sheet (e.g. cols K:L)
        .Range("K4").resize(ubound(names),1) = names
        .Columns("L").numberformat = "@"
        .Range("L4").resize(ubound(ids),1) = ids
    End With
    
End Sub