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>

通过一次管理一个单元格而只是做“＆lt;”就不那么难了＆安培; Cell（x，y）＆amp; “＆gt;” 中但我想要一个优雅的解决方案。这是我到目前为止的实现：

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

这可能看起来像一堆gobbledygook，但它基本上是在第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

所以，它比预期的要长一些，可能比优雅更加糟糕......但它确实有效。

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

3 个答案: