如何用VBA将多份Excel合并到单工作表并添加源文件名列？

以下是修改后的VBA代码，实现将所有选中Excel文件的所有工作表数据合并到单个工作表，并在首列添加对应源文件名称：

Sub MergeToSingleSheetWithFileName()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Dim wbkDestSheet As Worksheet
    Dim lastRowDest As Long, lastRowSrc As Long
    Dim firstData As Boolean
    
    ' 选择要合并的文件
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
    
    If vbBoolean <> VarType(fnameList) Then
        If UBound(fnameList) > 0 Then
            countFiles = 0
            countSheets = 0
            firstData = True ' 标记是否是第一个要复制的表头
            
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            
            Set wbkCurBook = ActiveWorkbook
            
            ' 创建或清空目标工作表
            On Error Resume Next
            Set wbkDestSheet = wbkCurBook.Sheets("合并结果")
            If Err.Number <> 0 Then
                Set wbkDestSheet = wbkCurBook.Sheets.Add(After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count))
                wbkDestSheet.Name = "合并结果"
            Else
                ' 清空已有内容
                wbkDestSheet.Cells.Clear
            End If
            On Error GoTo 0
            
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
                ' 获取源文件名（不含路径）
                Dim srcFileName As String
                srcFileName = Mid(fnameCurFile, InStrRev(fnameCurFile, "\") + 1)
                
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
                
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    lastRowSrc = wksCurSheet.Cells(wksCurSheet.Rows.Count, "A").End(xlUp).Row
                    
                    ' 如果源表有数据
                    If lastRowSrc >= 1 Then
                        lastRowDest = wbkDestSheet.Cells(wbkDestSheet.Rows.Count, "A").End(xlUp).Row
                        
                        If firstData Then
                            ' 复制表头和数据
                            wksCurSheet.Range("A1:" & wksCurSheet.Cells(lastRowSrc, wksCurSheet.UsedRange.Columns.Count).Address).Copy _
                                Destination:=wbkDestSheet.Cells(lastRowDest + 1, 2)
                            ' 填充文件名到首列
                            wbkDestSheet.Range("A1:A" & lastRowSrc).Value = srcFileName
                            firstData = False
                        Else
                            ' 跳过表头，复制数据行（从第2行开始）
                            wksCurSheet.Range("A2:" & wksCurSheet.Cells(lastRowSrc, wksCurSheet.UsedRange.Columns.Count).Address).Copy _
                                Destination:=wbkDestSheet.Cells(lastRowDest + 1, 2)
                            ' 填充文件名到首列
                            wbkDestSheet.Range("A" & (lastRowDest + 1) & ":A" & (lastRowDest + lastRowSrc - 1)).Value = srcFileName
                        End If
                    End If
                Next
                
                wbkSrcBook.Close savechanges:=False
            Next
            
            ' 自动调整列宽
            wbkDestSheet.Columns.AutoFit
            
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets into single sheet", Title:="Merge Complete"
        End If
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

关键修改说明 #

• 创建目标工作表：自动创建名为"合并结果"的工作表，若已存在则清空原有内容，确保每次合并都是全新结果；
• 合并到单工作表：不再复制整个工作表，而是将源表的数据区域复制到目标表的最后一行，实现所有数据集中在一个表；
• 添加源文件名：提取每个源文件的文件名（不含路径），在复制数据后填充到目标表的首列，对应每一行数据；
• 表头处理：仅保留第一个源表的表头，后续源表跳过表头直接复制数据行，避免重复表头；
• 数据范围优化：通过UsedRange和End(xlUp)获取有效数据区域，避免复制空行，提升效率；
• 自动列宽调整：合并完成后自动调整目标表的列宽，方便查看。

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