XML de visualización VBA con jerarquía en celdas

Estoy tratando de formatear el siguiente XML para imprimir de la misma manera jerárquica que aparece. Nodo de padre en la primera celda, en la siguiente fila, segundo niño de primera columna y su atributo si alguno y su niño nodos en las filas siguientes. Aquí está mi XML:


   
      directv_99e0857d-abf3-461c-913e-3ab59c6b5ef6
      1162969
      1.10
      2013-02-12T17:26:28.172Z
      2013-02-12T17:26:50.409Z
      CarePortal2
      
      P
      9
      en_US      
     
        9
        90001
        System error occurred
        
           
   
   
      45497
      1858186
      DTV ABC WOLE HE P
      138677
      202          
      
         185812386
         
         XXXX
         Tanna         
            

               3617490
               BILTO
               CASCADES
               202
               RIDGE HEAVEN
               
               STERLING
               VA
               20165
               LOUDOUN
               
               US
               
               US

Este es el código que he desarrollado para imprimir en las próximas filas y células adyacentes. Pero lo que necesito es como en la imagen adjunta Código:

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

Aquí está la salida esperada enter image description here

Pregunta hecha hace 3 años, 4 meses, 27 días - Por compilerhero

3 Respuestas:

  • Mostrar jerarquía XML en las columnas

    Como @Pat requiere un listado donde

    • los nombres de los nodos ocurren en columnas posteriores siguiendo el orden de sus nivel jerárquico,
    • valores de los nodos textuales en la columna derecha siguiente
    • atributos definiciones en la última columna,

    Añadí una enumeración en la parte superior para facilitar las referencias de columna cercanas al OP (la asunción se hace para incluir el nodo de nivel superior ~~ {e.e. Nivel 0, también).

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

    El procedimiento principal

    • [1] comienza a recursivo llamar para recoger cadenas node/atributo dentro de un array
    • [2] escribe los resultados a un determinado rango de destino.

    En este ejemplo preferí .Load un archivo de ejemplo en lugar de un .LoadXML cadena de contenido para permitir a los usuarios replicar la solución copiando el contenido XML de OP directamente en una carpeta de prueba en lugar de crear esta cadena a través de código VBA de forma de rotonda.

    Además, el xml se carga a través de tardío vinculante para permitir una carga simple para todos los usuarios; por supuesto, esto podría cambiarse fácilmente vinculante temprana.

    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

    Función Recursiva 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. 
     followed by node element ,
   '        (i.e. FirstChild.NodeType must not be of type NODE_TEXT = 3)
   '     b) e.g.  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

    Función de ayuda 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

    Respondida el Dec 19, 2020 a las 18:53 - por pixelpioneerc4b5

    Votos positivos: 0 | Votos negativos: 0

  • Para lograr la salida esperada con la jerarquía en las celdas adjuntas, es necesario realizar algunos ajustes en el código VBA. Aquí te dejo una versión modificada del código que debería ayudarte a lograr el formato deseado:

    vba
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
    i = 3
    Set X_sheet = ThisWorkbook.Sheets.Add
    X_sheet.Name = "XML_Output"

    Set oParentNode = rXml.DocumentElement
    Call List_ChildNodes(oParentNode, i, X_sheet)
End Sub

Sub List_ChildNodes(oParentNode, i, X_sheet)
    Dim Node_Set As Boolean
    For Each oChildNode In oParentNode.ChildNodes
        Node_Set = False
        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
                    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 > 0 Then
            Call List_ChildNodes(oChildNode, i, X_sheet)
        End If
    Next
End Sub

    Con estos cambios, se creará una nueva hoja de cálculo en el libro de Excel donde se imprimirá la jerarquía del XML de acuerdo a la estructura deseada. Recuerda que puedes ajustar el nombre de la hoja de cálculo y los detalles de formato según tus necesidades.

    Espero que este código te ayude a resolver tu problema. ¡Déjame saber si necesitas ayuda adicional!

    Respondida el Dec 20, 2020 a las 18:54 - por Gpt

    Votos positivos: 0 | Votos negativos: 0

  • Aquí tienes un código VBA actualizado que debería generar la salida XML jerárquica que deseas:

    vba
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
    Dim Parent_Name As String

    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
                Parent_Name = oChildNode.ParentNode.nodeName
                X_sheet.Cells(i, 1) = Parent_Name
                X_sheet.Cells(i, 2) = oChildNode.ParentNode.Text
                i = i + 1
            Else
                If Not ((oChildNode.Text & vbNullString) = vbNullString) Then
                    X_sheet.Cells(i, 1) = Parent_Name
                    X_sheet.Cells(i, 2) = oChildNode.Text
                    i = i + 1
                Else
                    X_sheet.Cells(i, 1) = Parent_Name
                    i = i + 1
                End If
            End If
        End If
    Next
End Sub

    Este código actualizado mantiene la sangría jerárquica desplazando el nombre del nodo principal a la columna A para cada nodo secundario. También he agregado una variable Parent_Name para rastrear el nombre del nodo principal para los nodos secundarios que no tienen un nombre de etiqueta.

    Respondida el Dec 20, 2020 a las 18:59 - por Gemini

    Votos positivos: 0 | Votos negativos: 0