Creación de un archivo XML a partir de celdas XLS mediante indentaciones

Question

Lo que intento hacer es crear un archivo XML analizando un archivo XLS. Un ejemplo debería ser más relevante:

| tag1  |   |   |   | 
|   | tag2  |   |   | 
|   |   | tag3  | tag3Value | 
|   |   | tag4  | tag4Value | 
|   | tag5  |   |   | 
|   |   | tag6  | tag6Value | 
|   |   |   |   | 

Si imaginamos que esas son las células, será equivalente para el siguiente código .xml.

<tag1> 
    <tag2> 
     <tag3> tag3Value </tag3> 
     <tag4> tag4Value </tag4> 
    </tag2> 
    <tag5> 
     <tag6> tag6Value </tag6> 
    </tag5> 
</tag1> 

Eso no sería tan duro mediante la gestión de una célula a la vez y sólo haciendo "<" & celular (x, y) & ">" pero quería una solución elegante. Aquí está mi aplicación hasta el momento:

Sub lol() 
    Sheet1.Activate 

    Dim xmlDoc As MSXML2.DOMDocument 
    Dim xmlNode As MSXML2.IXMLDOMNode 

    Set xmlDoc = New MSXML2.DOMDocument 
    createXML xmlDoc 
End Sub 

Sub createXML(xmlDoc As MSXML2.DOMDocument) 
    Dim newNode As MSXML2.IXMLDOMNode 

    If Not (Cells(1, 1) = "") Then 

     'newNode.nodeName = Cells(1, 1) 
     ReplaceNodeName xmlDoc, newNode, Cells(1, 1) 

     createXMLpart2 xmlDoc, newNode, 2, 2 
     xmlDoc.appendChild newNode 
    End If 
    xmlDoc.Save "E:\saved_cdCatalog.xml" 
End Sub 

Sub createXMLpart2(xmlDoc As MSXML2.DOMDocument, node As MSXML2.IXMLDOMElement, i As Integer, j As Integer) 
    Dim newNode As MSXML2.IXMLDOMElement 
    If Not (Cells(i, j) = "") Then 

     If (Cells(i, j + 1) = "") Then 

      'newNode.nodeName = Cells(i, j) 
      ReplaceNodeName xmlDoc, newNode, Cells(i, j) 

      createXMLpart2 xmlDoc, newNode, i + 1, j + 1 
     Else 
      'newNode.nodeName = "#text" 
      ReplaceNodeName xmlDoc, newNode, "#text" 

      'newNode.nodeValue = Cells(i, j + 1) 
      createXMLpart2 xmlDoc, newNode, i + 1, j 
     End If 
     node.appendChild (newNode) 
    End If 
End Sub 

Private Sub ReplaceNodeName(oDoc As DOMDocument, oElement As IXMLDOMElement, newName As String) 
     Dim ohElement As IXMLDOMElement 
     Dim sElement As IXMLDOMElement 
     Dim oChild As IXMLDOMNode 

     ' search the children ' 
     If Not oElement Is Nothing Then 
       Set ohElement = oElement.parentNode 
       Set sElement = oDoc.createElement(newName) 

       For Each oChild In oElement.childNodes 
         Call sElement.appendChild(oChild) 
       Next 

       Call ohElement.replaceChild(sElement, oElement) 
     End If 
End Sub 

problemas: en un primer momento no me di cuenta de que no puedo cambiar el nombre de un nodo haciendo node.nodeName = "nuevoNombre" Me han encontrado una solución en StackOverflow actualmente: Change NodeName of an XML tag element using MSXML

Así que he comentado mis intentos de cambiar el nombre de los nodos y probé la versión con el método ReplaceNodeName.

El problema real: node.appendChild (newNode) de createXMLpart2 me da un problema: se supone que la variable "newNode" no está configurada. Estoy desconcertado.

Answer 1

Tal vez algo como esto ...

Sub Tester() 

Dim r As Range 
Dim xmlDoc As New MSXML2.DOMDocument 
Dim xmlNodeP As MSXML2.IXMLDOMNode 
Dim xmlNodeTmp As MSXML2.IXMLDOMNode 
Dim bDone As Boolean 

    Set r = ActiveSheet.Range("A1") 

    Do While Not r Is Nothing 

     Set xmlNodeTmp = xmlDoc.createElement(r.Value) 
     If Len(r.Offset(0, 1).Value) > 0 Then 
      xmlNodeTmp.appendChild xmlDoc.createTextNode(r.Offset(0, 1).Value) 
     End If 

     If Not xmlNodeP Is Nothing Then 
      xmlNodeP.appendChild xmlNodeTmp 
     Else 
      xmlDoc.appendChild xmlNodeTmp 
     End If 
     Set xmlNodeP = xmlNodeTmp 

     If Len(r.Offset(1, 0).Value) > 0 Then 
      Set r = r.Offset(1, 0) 'sibling node 
      Set xmlNodeP = xmlNodeP.ParentNode 
     ElseIf Len(r.Offset(1, 1).Value) > 0 Then 
      Set r = r.Offset(1, 1) 'child node 
     Else 
      Set r = r.Offset(1, 0) 
      Set xmlNodeP = xmlNodeP.ParentNode 
      Do While Len(r.Value) = 0 
       If r.Column > 1 Then 
        Set r = r.Offset(0, -1) 
        Set xmlNodeP = xmlNodeP.ParentNode 
       Else 
        Set r = Nothing 
        Exit Do 
       End If 
      Loop 
     End If 

    Loop 
    Debug.Print xmlDoc.XML 
End Sub 

Answer 2

No soy un experto en VBA, pero mirando su código, no entiendo por qué cree que newNode se inicializaría.

Al comienzo de createXMLpart2(), lo declara como Dim newNode As MSXML2.IXMLDOMElement, pero ¿dónde le da un valor?

Answer 3

yo decidimos ir código VBA puro (por ejemplo, un grupo de bucles). Con lo que comencé era bastante pequeño, pero luego pensé "¿y si cambian los requisitos?". En otras palabras, además de su ejemplo, ¿y si el siguiente también se convirtió válida:

tag1        
    |tag2 | | | | | | 
    | |tag3 |tag3value | | | | 
    | |tag4 |tag4value | | | | 
    |tag5 | | | | | | 
    | |tag6 |tag6value | | | | 
tag9 | | | | | | | 
    |tag10 |tag10value | | | | | 
tag11 | | | | | | | 
    |tag12 | | | | | | 
    | |tag13 | | | | | 
    | | |tag14 |tag14value | | | 
    | | |tag15 |tag15value | | | 
tag16 |tag16value | | | | | | 
tag17 | | | | | | | 
    |tag18 | | | | | | 
    | |tag19 | | | | | 
    | | |tag20 | | | | 
    | | | |tag21 | | | 
    | | | | |tag22 | | 
    | | | | | |tag23 |tag23value 
    | | | | | |tag24 |tag24value 
    | | | |tag25 |tag25value | | 

Eso podría parecer un montón de jerigonza, pero es básicamente poner etiquetas con los valores antes y más allá de la columna 4.

Si nos vamos a vestir a esta xml, se vería algo como esto:

<tag1> 
    <tag2> 
     <tag3>tag3value</tag3> 
     <tag4>tag4value</tag4> 
    </tag2> 
    <tag5> 
     <tag6>tag6value</tag6> 
    </tag5> 
</tag1> 
<tag9> 
    <tag10>tag10value</tag10> 
</tag9> 
<tag11> 
    <tag12> 
     <tag13> 
      <tag14>tag14value</tag14> 
      <tag15>tag15value</tag15> 
     </tag13> 
    </tag12> 
</tag11> 
<tag16>tag16value</tag16> 
<tag17> 
    <tag18> 
     <tag19> 
      <tag20> 
       <tag21> 
        <tag22> 
         <tag23>tag23value</tag23> 
         <tag24>tag24value</tag24> 
        </tag22> 
       </tag21> 
       <tag25>tag25value</tag25> 
      </tag20> 
     </tag19> 
    </tag18> 
</tag17> 

Y es por eso que mi módulo hace:

'Assumptions: 
'1. No blank columns 
'2. XML values start at A1 
Option Explicit 

Dim m_lCurrentRow As Long 'The current row in the range of cells 
Dim m_xmlSheetRange As Range 'The current range of cells containing values 

'Let the fun begin 
Sub DoTheFun() 
    Dim lastUsedCell As Range 'The cell in the outer most row in th outer most column that contains a value 
    Dim lTotalRows As Long 'Total number of rows 
    Dim iCurrentColumn As Integer 


    'Find the very last used cell on a Worksheet: 
    'http://www.ozgrid.com/VBA/ExcelRanges.htm 
    Set lastUsedCell = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious) 

    'Set the range of values to check from A1 to wherever the last cell is located 
    Set m_xmlSheetRange = Range("$A$1:" & lastUsedCell.Address) 
    'Initialize (Sheets have an Option Base 1) 
    iCurrentColumn = 1 
    m_lCurrentRow = 1 
    lTotalRows = m_xmlSheetRange.Rows.Count 

    'Loop through all rows to create the XML string 
    Do Until m_lCurrentRow > lTotalRows 
     'Make sure adjacent cell does not have a value. 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" Then 

      'Start the search to find a tag with a value (write the surrounding tags as needed) 
      Debug.Print FindTagWithValue(iCurrentColumn) 

      iCurrentColumn = FindTagColumn(iCurrentColumn) 
     Else 'Adjacent cell has a value so just write out the tag and value 
      Debug.Print BuildTagWithValue(iCurrentColumn) 
     End If 
    Loop 


End Sub 
'Recursive function that calls itself till a tag with a value is found. 
Function FindTagWithValue(iCurrentColumn As Integer) As String 
    Dim sXml As String 
    Dim sMyTag As String 
    Dim iPassedColumn As Integer 
    Dim bTagClosed As Boolean 

    iPassedColumn = iCurrentColumn 

    'Get the opening and surrounding tag 
    sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
    sXml = String(iCurrentColumn - 1, vbTab) & "<" & sMyTag & ">" & vbCrLf 

    'Move to the next cell and next row 
    m_lCurrentRow = m_lCurrentRow + 1 
    iCurrentColumn = iCurrentColumn + 1 

    bTagClosed = False 'Intialize 

    Do 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" Then 
      'Adjancent cell to current position does not have value. Start recursion till we find it. 
      sXml = sXml & FindTagWithValue(iCurrentColumn) 
     Else 
      'A value for a tag has been found. Build the xml for the tag and tag value 
      sXml = sXml & BuildTagWithValue(iCurrentColumn) 

      'See if next row is on same level 
      If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) <> "" And iPassedColumn < iCurrentColumn Then 
       sXml = sXml & String(iPassedColumn - 1, vbTab) & "</" & sMyTag & ">" & vbCrLf 
       sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
       bTagClosed = True 
      End If 
     End If 
    'Keep looping till the current cell is empty or until the current column is less than the passed column 
    Loop Until m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) = "" Or iPassedColumn >= iCurrentColumn 

    If Not bTagClosed Then 
     sXml = sXml & String(iPassedColumn - 1, vbTab) & "</" & sMyTag & ">" & vbCrLf 
    End If 

    FindTagWithValue = sXml 

    Exit Function 

End Function 
'A cell with a value has been found that also contains an adjacent cell with a value. Wrap the tag around the value. 
Function BuildTagWithValue(iCurrentColumn As Integer) 
    Dim sXml As String 
    Dim sMyTag As String 
    Dim sMyTagValue As String 

    Do 

     sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
     sMyTagValue = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) 
     sXml = sXml & String(iCurrentColumn - 1, vbTab) & "<" & sMyTag & ">" & sMyTagValue & "</" & sMyTag & ">" & vbCrLf 
     m_lCurrentRow = m_lCurrentRow + 1 
    'Keep looping till you run out of tags with values in this column 
    Loop Until m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" 

    'Find the next valid column 
    iCurrentColumn = FindTagColumn(iCurrentColumn) 

    BuildTagWithValue = sXml 

    Exit Function 
End Function 
'Find the cell on the current row which contains a value. 
Function FindTagColumn(iCurrentColumn) As Integer 
    Dim bValidTagFound As Boolean 

    bValidTagFound = False 
    Do Until bValidTagFound 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) = "" Then 
      If iCurrentColumn = 1 Then 
       bValidTagFound = True 
      Else 
       iCurrentColumn = IIf(iCurrentColumn = 1, 1, iCurrentColumn - 1) 
      End If 
     Else 
      bValidTagFound = True 
      If iCurrentColumn = 1 Then 
       'Do nothing 
      Else 
       If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn - 1) <> "" Then 
        iCurrentColumn = iCurrentColumn - 1 
       End If 
      End If 
     End If 
    Loop 

    FindTagColumn = iCurrentColumn 
    Exit Function 
End Function 

Por lo tanto, es un poco más largo de lo esperado y podría ser más divertido que elegante ... pero funciona.