通过缩进从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>

通过一次管理一个单元格并只执行"<“& Cell(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

因此，它比预期的要长一点，而且可能比elegant...but它的工作原理更古怪。