Excel VBA遍历所有工作表生成单个XML文件问题排查

我来帮你搞定这个问题！你目前的代码遇到两个核心问题：一是循环遍历工作表时始终读取第一个工作表的数据，二是每次循环都会重新创建XML文件，无法将所有工作表的数据整合到单个文件中。我们来一步步修正并优化代码。

原代码的问题分析 #

• 未正确指定工作表范围：原代码中Cells(1, I)没有加上工作表对象sht.前缀，默认会引用ActiveSheet（也就是你点击按钮时的那个工作表），导致始终读取第一个表的内容。
• XML文件重复创建：strPfad在For Each sht循环内部定义，每次循环都会生成一个新的带时间戳的XML文件，而不是将所有数据写入同一个文件。
• 缺少合法的XML根结构：原代码没有定义XML的根节点，生成的XML文件结构不合法。

修正后的完整代码 #

Sub GenerateSingleXMLFromAllSheets()
    Dim sht As Worksheet
    Dim loLetzteZ As Long, loLetzteS As Long, I As Long
    Dim rBereich As Range, rng As Range
    Dim sTagO As String, sTagC As String, sTagOEnd As String, sTagCStart As String
    Dim sZeile As String
    Dim strPfad As String
    Dim strText As String
    
    ' 定义XML标签的基础组成部分
    sTagO = "<"
    sTagOEnd = "/>"
    sTagC = ">"
    sTagCStart = "</"
    
    ' 设置XML文件路径（仅创建一次，放在循环外）
    strPfad = ActiveWorkbook.Path & "\AllSheets_Classification_" & Format(Now, "yyyyMMdd_hhmmss") & ".xml"
    Application.ScreenUpdating = False
    
    ' 写入XML头部和根节点
    strText = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
    strText = strText & "<AllClassifications>" & vbCrLf & vbCrLf
    Call InDateiSchreiben(strPfad, strText, False) ' 覆盖写入初始内容
    
    ' 遍历所有工作表
    For Each sht In ThisWorkbook.Worksheets
        ' 跳过名为"Description"的工作表（因为按钮在这个表上，不需要处理它的数据）
        If sht.Name <> "Description" Then
            loLetzteZ = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
            loLetzteS = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
            
            ' 确保数据行至少从第2行开始
            If loLetzteZ >= 2 Then
                Set rBereich = sht.Range("A2:" & sht.Cells(loLetzteZ, loLetzteS).Address)
                
                ' 遍历当前工作表的每一行数据
                For Each rng In rBereich.Rows
                    sZeile = "  <Classification>" & vbCrLf ' 每个数据行的父节点
                    
                    With rng
                        ' 遍历当前行的每一列
                        For I = 1 To .Columns.Count
                            Dim header As String
                            header = Trim(sht.Cells(1, I).Value)
                            
                            ' 跳过空表头的列
                            If header <> "" Then
                                Dim cellValue As String
                                cellValue = Trim(.Cells(1, I).Value)
                                
                                If I = 1 Then
                                    ' 第一列作为属性（根据原代码逻辑）
                                    sZeile = sZeile & "    " & sTagO & header & "=""" & cellValue & """" & sTagC & vbCrLf
                                Else
                                    If IsEmpty(.Cells(1, I)) Then
                                        ' 空值列写入自闭合标签
                                        sZeile = sZeile & "    " & sTagO & header & sTagOEnd & vbCrLf
                                    Else
                                        ' 非空值写入完整的开闭标签
                                        sZeile = sZeile & "    " & sTagO & header & sTagC
                                        sZeile = sZeile & cellValue
                                        sZeile = sZeile & sTagCStart & header & sTagC & vbCrLf
                                    End If
                                End If
                            End If
                        Next I
                    End With
                    
                    sZeile = sZeile & "  </Classification>" & vbCrLf & vbCrLf
                    Call InDateiSchreiben(strPfad, sZeile, True) ' 追加写入当前行数据
                    sZeile = ""
                Next rng
            End If
        End If
    Next sht
    
    ' 写入XML根节点的闭合标签
    strText = "</AllClassifications>"
    Call InDateiSchreiben(strPfad, strText, True)
    
    Application.ScreenUpdating = True
    MsgBox "单个XML文件已生成！路径：" & strPfad, vbInformation
End Sub

' 确保你的InDateiSchreiben函数是正确的（这里附上标准实现以防你缺少）
Sub InDateiSchreiben(strPfad As String, strText As String, blnAppend As Boolean)
    Dim intFile As Integer
    intFile = FreeFile()
    Open strPfad For IIf(blnAppend, Append, Output) As #intFile
    Print #intFile, strText;
    Close #intFile
End Sub

关键修改说明 #

• 指定工作表范围：所有Cells和Range引用都加上了sht.前缀，确保读取当前遍历的工作表的数据，而不是ActiveSheet。
• 单个XML文件生成：将strPfad的定义移到循环外部，确保只创建一个文件，后续所有数据都追加到这个文件中。
• 跳过Description工作表：添加了判断sht.Name <> "Description"，避免处理按钮所在的工作表数据。
• 合法XML结构：添加了XML声明和根节点<AllClassifications>，确保生成的XML文件符合格式规范。
• 空表头处理：增加了对空表头列的跳过逻辑，避免生成无效的XML标签。
• 用户提示：最后添加了消息框，告知用户文件生成成功及路径。

使用方法 #

1. 打开你的Excel文件，按下Alt + F11打开VBA编辑器。
2. 将上述代码粘贴到对应的模块中（如果没有模块，右键点击工作簿名称→插入→模块）。
3. 回到Excel的Description工作表，插入一个按钮（开发工具→插入→按钮（表单控件）），然后关联到GenerateSingleXMLFromAllSheets宏。
4. 点击按钮即可一键生成包含所有工作表数据的单个XML文件。

内容的提问来源于stack exchange，提问作者Jacky Daniels