Рекурсивный вызов для анализа структуры XML
Здесь вы найдете общий метод анализа вашей полной структуры XML с результатами, записанными в 2-dim Array v. Я бы порекомендовал использовать текущую версию MSXML 6.0, а также рекурсивные вызовы , позволяющие углубиться в любую структуру узла.
Пример кода вызова
Sub DisplayXML()
' Purpose: write structured node information to array
' and display results in [2a] immediate window and/or [2b] worksheet of your choice
' Author: T.M.
Dim sXML$, i&, ii&
Dim XMLFile As Object
'Set XMLFile = CreateObject("Microsoft.XMLDOM") ' last stable version 3.0
Set XMLFile = CreateObject("MSXML2.DOMDocument.6.0") ' <~~ recommended version 6.0
XMLFile.Async = False
XMLFile.ValidateOnParse = False
sXML = GetXMLContentString() ' get XML content as string value
If XMLFile.LoadXML(sXML) Then ' check correct loading
'Debug.Print XMLFile.XML
' [1] write xml info to array with exact or assumed items count
Dim v As Variant: ReDim v(1 To XMLFile.SelectNodes("//*").Length, 1 To 2)
listChildNodes XMLFile.DocumentElement, v ' call helper function
' [2a] write results to immediate window ' change to your sheet name
For i = LBound(v) To UBound(v)
If Len(v(i, 2)) > 0 Then Debug.Print v(i, 2)
Next i
' [2b] write results to sheet "Dump" showing complete structure
With ThisWorkbook.Worksheets("Dump") ' <~~ change to any wanted sheet name
.Range("A:B") = "" ' clear result range
.Range("A1:B1") = Array("XML Tag", "Node Value") ' titles
.Range("A2").Resize(UBound(v), UBound(v, 2)) = v ' get 2-dim info array
End With
Else
MsgBox "Load Error "
End If
Set XMLFile = Nothing
End Sub
Function GetXMLContentString() As String
' Purpose: return specific XML content string (to be loaded as string)
Dim sXML$ ' data type string
sXML = "<DATA>" & _
" <LEVEL_1>" & _
" <col_1>ALevel1_col1</col_1>" & _
" <col_2>ALevel1_col2</col_2>" & _
" <LEVEL_2>" & _
" <col_1>BLevel2_col1</col_1>" & _
" <col_2>BLevel2_col2</col_2>" & _
" <LEVEL_3>" & _
" <col_1>CLevel3_col1</col_1>" & _
" <col_2>CLevel3_col2</col_2>" & _
" </LEVEL_3>" & _
" </LEVEL_2>" & _
" <LEVEL_2>" & _
" <col_1>B_Level2_col1</col_1>" & _
" <col_2>B_Level2_col2</col_2>" & _
" </LEVEL_2>" & _
" </LEVEL_1>"
sXML = sXML & " <LEVEL_1>" & _
" <col_1>XLevel1_col1</col_1>" & _
" <col_2>XLevel1_col2</col_2>" & _
" <LEVEL_2>" & _
" <col_1>YLevel2_col1</col_1>" & _
" <col_2>YLevel2_col2</col_2>" & _
" <LEVEL_3>" & _
" <col_1>ZLevel3_col1</col_1>" & _
" <col_2>ZLevel3_col2</col_2>" & _
" </LEVEL_3>" & _
" </LEVEL_2>" & _
" <LEVEL_2>" & _
" <col_1>Y_Level2_col1</col_1>" & _
" <col_2>Y_Level2_col2</col_2>" & _
" </LEVEL_2>" & _
" </LEVEL_1>" & _
"</DATA>"
GetXMLContentString = sXML ' return
End Function
Вспомогательные функции
Function listChildNodes(oCurrNode As Object, _
ByRef v As Variant, _
Optional ByRef i As Long = 1, _
Optional iLvl As Integer = 0 _
) As Boolean
' Purpose: assign the complete node structure with contents to a 1-based 2-dim array
' Author: T.M. (https://stackoverflow.com/users/6460297/t-m)
' 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
' 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 2, 1 To UBound(v) + 1000) ' increase row numbers
v = Application.Transpose(tmp) ' transpose back
Erase tmp
End If
Const NAMEColumn& = 1, VALUEColumn& = 2 ' constants for column 1 and 2
' 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, VALUEColumn) = String((iLvl - 1) * 2, " ") & " " & 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. <LEVEL_1> followed by node element <col_1>,
' (i.e. FirstChild.NodeType must not be of type NODE_TEXT = 3)
' b) node element without any child node (e.g. last <col_2> child node in last LEVEL_2 element)
' 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, NAMEColumn) = String(iLvl * 2, " ") & _
oCurrNode.nodename & 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, iLvl + 1)
If bDisplay Then
v(i, NAMEColumn) = String(iLvl * 2, " ") & _
oCurrNode.nodename & 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, VALUEColumn) = "<!-- " & oCurrNode.NodeValue & "-->"
i = i + 1
End If
' return
listChildNodes = False
End If
End Function
'Helper function getAtts()
Function getAtts(ByRef node As Object) As String
' Purpose: return attribute(s) string in brackets, e.g. '[@num="123"]'
' Note: called by above function listChildNodes()
' not needed in OP, just in case there exist attribute names
' Author: T.M. (https://stackoverflow.com/users/6460297/t-m)
Dim sAtts$, ii&
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