Excel VBA在单元格中显示具有层次结构的XML
我正在尝试格式化下面的XML，以便以它显示的相同分层方式打印。 第一个单元格、下一行、第二列中的父节点、第一个子节点及其属性（如果有）以及后续行中的子节点。 以下是我的XML：Excel VBA在单元格中显示具有层次结构的XML,excel,xml,vba,ixmldomdocument,Excel,Xml,Vba,Ixmldomdocument,我正在尝试格式化下面的XML，以便以它显示的相同分层方式打印。 第一个单元格、下一行、第二列中的父节点、第一个子节点及其属性（如果有）以及后续行中的子节点。 以下是我的XML： <ResponseEnvelope xmlns="http://www.nwabcdfdfd.com/messagin" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.or
<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>
在列中显示XML层次结构 As@Pat需要一个列表，其中
- 节点名称按照其层次结构级别的顺序出现在后续列中
- 右下列中的文本节点值和
- 最后一列中的属性定义
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
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
请参阅我的文章，通过递归函数调用显示XML结构，包括属性，这些函数可以根据您的需要在单个列显示中轻松更改；如果有帮助，请反馈或可能的升级：-）@T.M.您的代码几乎可以满足我90%的需求，但我的要求是将其放在不同的列中，而不是缩进到同一列中。感谢您的参考发布了符合您要求的99%代码：-）顺便说一句，将示例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
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
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