我懂你的需求啦——原来的代码会把每个源工作簿里的工作表都复制成当前工作簿的独立新表，但你想要的是把所有工作簿的所有数据都合并到同一个工作表里。咱们来调整这段代码，替换掉sheets.Copy的逻辑，改成直接复制数据并追加到目标工作表。

修改后的完整代码 #

Sub MergeMultipleWorkbooksIntoOneSheet()
    Dim fileDialog As FileDialog
    Dim mainWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim targetSheet As Worksheet
    Dim sourceSheet As Worksheet
    Dim lastRowTarget As Long
    Dim lastRowSource As Long
    Dim i As Integer
    Dim isFirstFile As Boolean
    
    ' 设置当前工作簿为目标工作簿
    Set mainWorkbook = Application.ActiveWorkbook
    ' 创建一个新工作表作为合并目标（也可以指定现有工作表，比如mainWorkbook.Sheets(1)）
    Set targetSheet = mainWorkbook.Sheets.Add(After:=mainWorkbook.Sheets(mainWorkbook.Sheets.Count))
    targetSheet.Name = "合并数据"
    
    ' 初始化标记：第一个文件需要复制表头
    isFirstFile = True
    
    ' 打开文件选择对话框，允许多选
    Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fileDialog
        .AllowMultiSelect = True
        .Title = "选择要合并的工作簿"
        .Filters.Add "Excel文件", "*.xlsx;*.xls;*.xlsm"
        If .Show = -1 Then ' 用户选择了文件
            For i = 1 To .SelectedItems.Count
                ' 打开源工作簿（设置为只读避免权限问题）
                Set sourceWorkbook = Workbooks.Open(.SelectedItems(i), ReadOnly:=True)
                
                ' 遍历源工作簿的每个工作表
                For Each sourceSheet In sourceWorkbook.Worksheets
                    ' 找到目标工作表的最后一行（避免覆盖已有数据）
                    lastRowTarget = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
                    ' 找到源工作表的最后一行
                    lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
                    
                    If lastRowSource >= 1 Then ' 源工作表有数据才处理
                        If isFirstFile Then
                            ' 第一个文件：复制整行数据（包含表头）
                            sourceSheet.Rows("1:" & lastRowSource).Copy _
                                Destination:=targetSheet.Rows(lastRowTarget + 1)
                            isFirstFile = False ' 后续文件不再复制表头
                        Else
                            ' 后续文件：从第二行开始复制（跳过表头）
                            sourceSheet.Rows("2:" & lastRowSource).Copy _
                                Destination:=targetSheet.Rows(lastRowTarget + 1)
                        End If
                    End If
                Next sourceSheet
                
                ' 关闭源工作簿，不保存任何修改
                sourceWorkbook.Close SaveChanges:=False
            Next i
        End If
    End With
    
    MsgBox "数据合并完成！", vbInformation
End Sub

关键修改说明 #

• 替换Copy逻辑：不再复制整个工作表，而是复制源工作表的数据区域，粘贴到目标工作表的最后一行下方
• 表头处理：通过isFirstFile标记，只保留第一个文件的表头，后续文件直接从第二行开始复制数据，避免重复表头
• 目标工作表：代码里新建了名为「合并数据」的工作表作为目标，你也可以改成指定现有工作表（比如把Set targetSheet = ...改成Set targetSheet = mainWorkbook.Sheets("你的目标表名")）
• 只读打开源文件：打开源工作簿时设置ReadOnly:=True，避免因文件锁定导致的错误
• 空表判断：增加了lastRowSource >=1的判断，跳过没有数据的空工作表

内容的提问来源于stack exchange，提问作者harsha kazama