通過縮進從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 

所以，它比預期的要長一點，可能比優雅更蹩腳......但它的工作原理。