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

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

xml vba

通过缩进从XLS单元格创建XML文件,xml,vba,Xml,Vba,我试图做的是通过解析XLS文件来创建XML文件。一个例子应该更相关： | tag1 | | | | | | tag2 | | | | | | tag3 | tag3Value | | | | tag4 | tag4Value | | |

我试图做的是通过解析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>

问题：起初我没有意识到我不能通过node.nodeName=“newName”更改节点的名称实际上，我已经找到了StackOverflow的解决方案：

因此，我已经对重命名节点的尝试进行了评论，并尝试使用ReplaceNodeName方法创建该版本

实际问题：createXMLpart2中的node.appendChild（newNode）给了我一个问题：它说变量“newNode”没有设置。

我很困惑。

我不是VBA专家，但看看你的代码，我不明白你为什么认为

newNode

会被初始化

在

createXMLpart2（）

的开头，您将其声明为

将newNode设置为MSXML2.ixmldemelement

，但是在哪里给它赋值呢？

可能是这样的

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

我决定使用纯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>


tag3value
tag4value
Tag6值
Tag10值
Tag14值
Tag15值
Tag16值
Tag23值
Tag24值
Tag25值

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

'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

”假设：
'1.没有空白列
'2.XML值从A1开始
选项显式
将m_lCurrentRow设置为单元格范围内当前行的长度
Dim m_xmlSheetRange As Range'包含值的单元格的当前范围
“让乐趣开始吧
Sub DoTheFun（）
Dim lastUsedCell As Range“最外层列中最外层行中包含值的单元格
Dim lTotalRows As Long“行总数”
Dim iCurrentColumn作为整数
'查找工作表上最后使用的单元格：
'http://www.ozgrid.com/VBA/ExcelRanges.htm
设置lastUsedCell=Cells.Find（内容：=“*”，后面：=[A1]，搜索方向：=xlPrevious）
'设置要检查的值范围，从A1到最后一个单元格所在的位置
设置m_xmlSheetRange=Range（$A$1:&lastUsedCell.Address）
'初始化（图纸有一个选项Base 1）
iCurrentColumn=1
m_lCurrentRow=1
lTotalRows=m_xmlSheetRange.Rows.Count
'循环所有行以创建XML字符串
直到m_lCurrentRow>lTotalRows
'确保相邻单元格没有值。
如果m_xmlSheetRange（m_lCurrentRow，iCurrentColumn+1）=“”，则
'启动搜索以查找具有值的标记（根据需要写入周围的标记）
调试。打印FindTagWithValue（iCurrentColumn）
iCurrentColumn=FindTagColumn（iCurrentColumn）
Else的相邻单元格有一个值，所以只需写出标记和值
调试。打印BuildTagWithValue（iCurrentColumn）
如果结束
环
端接头
'递归函数，它调用自身直到找到带有值的标记。
函数FindTagWithValue（iCurrentColumn为整数）为字符串
作为字符串的Dim-sXml
Dim sMyTag As字符串
将iPassedColumn设置为整数
Dim bTagClosed为布尔值
iPassedColumn=iCurrentColumn
'获取开口和周围标记
sMyTag=m_xmlSheetRange（m_lCurrentRow，iCurrentColumn）
sXml=字符串（iCurrentColumn-1，vbTab）&“&vbCrLf
'移动到下一个单元格和下一行
m_lCurrentRow=m_lCurrentRow+1
iCurrentColumn=iCurrentColumn+1
bTagClosed=False“初始化”
做
如果m_xmlSheetRange（m_lCurrentRow，iCurrentColumn+1）=“”，则
'当前位置的相邻单元格没有值。开始递归，直到找到为止。
sXml=sXml&FindTagWithValue（iCurrentColumn）
其他的
'已找到标记的值。为标记和标记值构建xml
sXml=sXml&BuildTagWithValue（iCurrentColumn）
'查看下一行是否位于同一级别
如果m_xmlSheetRange（m_lCurrentRow，iCurrentColumn）“”和iPassedColumn=iCurrentColumn
如果没有关闭，那么
sXml=sXml和字符串（iPassedColumn-1，vbTab）和“”&vbCrLf
如果结束
FindTagWithValue=sXml
退出功能
端函数
'已找到具有值的单元格，该单元格还包含具有值的相邻单元格。将标记环绕在值周围。
函数BuildTagWithValue（iCurrentColumn为整数）
作为字符串的Dim-sXml
Dim sMyTag As字符串
作为字符串的Dim SMYTAGGVALUE
做
sMyTag=m_xmlSheetRange（m_lCurrentRow，iCurrentColumn）
sMyTagValue=m_xmlSheetRange（m_lCurrentRow，iCurrentColumn+1）
sXml=sXml&String（iccurrentcolumn-1，vbTab）&“&sMyTagValue&”&vbCrLf
m_lCurrentRow=m_lCurrentRow+1
'继续循环，直到此列中包含值的标记用完为止
循环直到m_xmlSheetRange（m_lCurrentRow，iCurrentColumn+1）=“”
'查找下一个有效列
iCurrentColumn=FindTagColumn（iCurrentColumn）
BuildTagWithValue=sXml
退出功能
端函数
“找到上面的牢房
'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