通过缩进从XLS单元格创建XML文件

Question

我想要做的是通过解析一个XLS文件来创建一个XML文件。 一个例子应该是更相关：

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

如果我们想象这些都是细胞，将相当于以下.XML代码。

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

，才不会被管理每次一个单元，只是在做“<” &细胞（X，Y）&“>”这么辛苦 但我想要一个完美的解决方案。这里是我的执行至今：

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 

问题：一开始我并没有意识到，我不能这样做node.nodeName =“了newName” 更改节点的名字我已经找到一个解决方案StackOverflow其实：Change NodeName of an XML tag element using MSXML

所以我已经评论了我重命名节点的尝试，并尝试使用ReplaceNodeName方法的版本。

实际的问题：createXMLpart2的node.appendChild（newNode）给我一个问题：它是变量“newNode”没有设置。 我很困惑。

Answer 1

也许这样的事情...

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

我不是VBA的专家，但看着你的代码，我不明白你为什么认为newNode会被初始化。

在createXMLpart2()开头，你声明它为 Dim newNode As MSXML2.IXMLDOMElement，但你在哪里给它一个值？

Answer 3

我决定去纯粹的VBA代码（如一串环）。我开始的时间相当短，但是后来我想“如果要求改变了，该怎么办？”。换句话说，除了你比方说，如果下面还成为有效：

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 | | 

这可能看起来像一堆官样文章的，但它基本上把标签与值之前及以后的第4列

如果我们要打扮这个XML，它会是这个样子：

<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> 

这就是为什么我的模块会：

'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 

所以，它比预期的要长一点，可能比优雅更蹩脚......但它的工作原理。