需求：按同名工作表合并多Excel文件并添加源文件名列

需求说明 #

需要批量合并指定文件夹下的所有Excel文件，要求：

• 同名工作表对应合并，保留原工作表名称
• 每个合并后的工作表首列添加SOURCE列，填入对应源文件名
• 合并后无空行，便于筛选
• 无需硬编码文件名和工作表名，动态读取

输入示例 #

a.xlsx的「fred」工作表：

a.xlsx的「bill」工作表：

b.xlsx的「fred」工作表：

b.xlsx的「bill」工作表：

期望输出 #

consolidated.xlsx的「fred」工作表：

consolidated.xlsx的「bill」工作表：

优化后的VBA代码 #

Sub ConsolidateWorkbooksByFolder()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim lastRowDest As Long
    Dim lastRowSource As Long
    Dim lastColSource As Integer
    Dim folderPath As String
    Dim fileName As String
    Dim sourceFileName As String
    
    ' 关闭屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 创建合并结果工作簿并命名
    Set wbDest = Workbooks.Add
    wbDest.SaveAs Filename:="consolidated.xlsx"
    
    ' 选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择要合并的Excel文件所在文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，程序退出"
            Application.ScreenUpdating = True
            Exit Sub
        End If
    End With
    
    ' 遍历文件夹下的所有Excel文件
    fileName = Dir(folderPath & "*.xls*")
    Do While fileName <> ""
        ' 跳过结果文件本身，避免循环处理
        If fileName <> "consolidated.xlsx" Then
            Set wbSource = Workbooks.Open(folderPath & fileName)
            sourceFileName = wbSource.Name ' 获取源文件名
            
            ' 遍历源文件中的每个工作表
            For Each wsSource In wbSource.Worksheets
                ' 检查目标工作簿中是否已存在同名工作表
                On Error Resume Next
                Set wsDest = wbDest.Worksheets(wsSource.Name)
                On Error GoTo 0
                
                ' 如果不存在，新建工作表并添加SOURCE表头
                If wsDest Is Nothing Then
                    Set wsDest = wbDest.Worksheets.Add(After:=wbDest.Sheets(wbDest.Sheets.Count))
                    wsDest.Name = wsSource.Name
                    ' 添加SOURCE列表头
                    wsDest.Cells(1, 1).Value = "SOURCE"
                    ' 复制源表表头到目标表的第2列开始
                    wsSource.Rows(1).Copy Destination:=wsDest.Cells(1, 2)
                    lastRowDest = 1 ' 表头行已存在，下一行从2开始
                Else
                    ' 找到目标表最后一行
                    lastRowDest = wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Row
                End If
                
                ' 获取源表数据区域（跳过表头）
                lastRowSource = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
                lastColSource = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
                
                ' 如果源表有数据（行数大于1）
                If lastRowSource > 1 Then
                    ' 复制源表数据到目标表的下一行，从第2列开始
                    wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRowSource, lastColSource)).Copy _
                        Destination:=wsDest.Cells(lastRowDest + 1, 2)
                    
                    ' 在SOURCE列批量填充源文件名
                    wsDest.Range(wsDest.Cells(lastRowDest + 1, 1), wsDest.Cells(lastRowDest + lastRowSource - 1, 1)).Value = sourceFileName
                End If
            Next wsSource
            
            ' 关闭源文件，不保存
            wbSource.Close SaveChanges:=False
        End If
        
        ' 取下一个文件
        fileName = Dir()
    Loop
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "合并完成，结果已保存为consolidated.xlsx"
End Sub

关键改动说明 #

1. 文件夹批量处理：替换原文件选择为文件夹选择，自动遍历文件夹下所有Excel文件，更适合批量操作
2. SOURCE列处理：
   • 新建工作表时自动添加SOURCE表头
   • 每次复制数据后，批量填充对应源文件名到SOURCE列
3. 避免重复表头：仅在新建工作表时复制源表表头，后续只复制数据行
4. 无空行保证：精准定位目标表最后非空行，数据直接接在后面，无空白行
5. 效率优化：关闭屏幕刷新减少卡顿；跳过结果文件本身，避免重复处理

内容的提问来源于stack exchange，提问作者Rob Oakley