如何快速的合并多个 Excel 工作簿成为一个工作簿并出现每个的名称

要快速合并多个Excel工作簿成为一个工作簿并在每个工作簿的名称内出现，可以使用Excel的合并工作表功能。通过这个功能，你可以将多个工作簿的内容汇总到一个工作簿中，并在每个工作簿的名称下方追加显示每个工作簿的名称，使得汇总后的工作簿更加清晰和易于管理。这个方法可以帮助你快速整合多个数据来源，并且保留原始数据的来源信息，提高工作效率和数据管理的准确性。

***************************************************

合并多个工作薄并有各个工作薄名称代码如下：

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&, h, zgx

Set sh = ActiveSheet

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Cells.ClearContents

Do While MyName <> ""

If MyName <> ThisWorkbook.Name Then

With GetObject(MyPath & MyName)

h = sh.[a65536].End(xlUp).Row

'Rows(h).Insert shift:=xlUp

For Each sht In .Sheets

If IsSheetEmpty = IsEmpty(sht.UsedRange) Then

m = m + 1

If m = 1 Then

sht.[a1].CurrentRegion.Copy sh.[a1]

Else

sht.[a1].CurrentRegion.Offset(0).Copy sh.[a65536].End(xlUp).Offset(1)

End If

'Debug.Print m

'Debug.Print h

'Cells(sh.UsedRange.Rows.Count, 1) = MyName

For zgx = h To sht.UsedRange.Rows.Count + h - 1 'sht.UsedRange.Rows.Count是各个分表的行高，h是汇总表的原行高，sht.UsedRange.Rows.Count + h是现行高。

sh.Cells(zgx + 1, 1) = MyName

'sh.Cells(h + 1, 1).Offset(0, 1) = "合计"

Cells(m, 8) = MyName

'Debug.Print sht.UsedRange.Rows.Count, h, sht.UsedRange.Rows.Count + h - 1

End If

.Close False

End With

End If

MyName = Dir

Loop

Application.ScreenUpdating = True

End Sub

****************************************************

用一个VBA就可以实现的。

使用方法：

1、新建一个工作薄，将其命名为你合并后的名字。

2、打开此工作薄。

3、在其下任一个工作表标签上点击右键，选择“查看代码”。

4、在打开的VBA编辑窗口中粘贴以下代码：

Sub 工作薄间工作表合并()

Dim FileOpen

Dim X As Integer

Application.ScreenUpdating = False

FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")

X = 1

While X <= UBound(FileOpen)

Workbooks.Open Filename:=FileOpen(X)

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

X = X + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

errhadler:

MsgBox Err.Description

End Sub

5、关闭VBA编辑窗口。

6、在excel中，工具---宏---宏,选“工作薄间工作表合并”,然后“执行”。

7、在打开的对话窗口中，选择你要合并的300个工作薄。

8、等待。。。。ok！

Sub 工作薄间工作表合并()Dim FileOpenDim X As IntegerApplication.ScreenUpdating = FalseFileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xlsx),*.xlsx", MultiSelect:=True, Title:="合并工作薄")X = 1While X <= UBound(FileOpen)Workbooks.Open Filename:=FileOpen(X)Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)X = X + 1WendExitHandler:Application.ScreenUpdating = TrueExit Suberrhadler:MsgBox Err.DescriptionEnd Sub

-05-15更新：如果是excel及更新的版本，则需要把代码中的xls修改为xlsx即可，祝大家成功！

------------------------------------------------------------------------------------------------------------------------

没人给直接答案，那我自问自答了。

的确去百度了下，出现了很多种方法，但是，目前就这个方法行得通，跟大家分享下：

用一个VBA就可以实现的。

使用方法：

1、新建一个工作薄，将其命名为你合并后的名字。

2、打开此工作薄。

3、在其下任一个工作表标签上点击右键，选择“查看代码”。

4、在打开的VBA编辑窗口中粘贴以下代码：

Sub 工作薄间工作表合并()

Dim FileOpen

Dim X As Integer

Application.ScreenUpdating = False

FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")

X = 1

While X <= UBound(FileOpen)

Workbooks.Open Filename:=FileOpen(X)

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

X = X + 1

Wend

ExitHandler:

Application.ScreenUpdating = True

Exit Sub

errhadler:

MsgBox Err.Description

End Sub

5、关闭VBA编辑窗口。

6、在excel中，工具---宏---宏,选“工作薄间工作表合并”,然后“执行”。

7、在打开的对话窗口中，选择你要合并的300个工作薄。

8、等待。。。。ok！

之前写过一个真实的案例，可以参考下，这是最复杂的情况之一，请看下面介绍：

-----------------------------------------------------------------------

1、

一个文件夹下有很多个工作簿。

2、

每个工作簿里面有3个sheet表，结构一样。

-----------------------------------------------------------------------

3、

要求如上，根据名称、代号、长度三个条件，汇总数量。这是多工作簿，多工作表，多条件汇总。具有代表性。

-----------------------------------------------------------------------

代码如下：

Option ExplicitSub 汇总2() Dim i%, j%, f$, k%, n%, m% Dim wb As Workbook, sht As Worksheet Dim d As Object, s Dim arr, arr1() Set d = CreateObject("scripting.dictionary") s = Timer f = Dir(ThisWorkbook.Path & "\*test*.xlsx") Application.ScreenUpdating = False Application.DisplayAlerts = False Do While f <> "" Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f) For Each sht In Worksheets sht.Activate i = [a100000].End(3).Row arr = Range("A3:D" & i) For k = 1 To UBound(arr) If Not d.exists(arr(k, 1) & arr(k, 2) & arr(k, 3)) Then n = n + 1 d(arr(k, 1) & arr(k, 2) & arr(k, 3)) = n ReDim Preserve arr1(1 To 4, 1 To n) '必须重新定义数组的维度 arr1(1, n) = arr(k, 1) arr1(2, n) = arr(k, 2) arr1(3, n) = arr(k, 3) arr1(4, n) = arr(k, 4) Else m = d(arr(k, 1) & arr(k, 2) & arr(k, 3)) arr1(4, m) = arr1(4, m) + arr(k, 4) End If Next k Erase arr Next sht wb.Close False f = Dir Loop Range("A2").Resize(d.Count, 4) = Application.Transpose(arr1) Range("A1:D1") = Array("名称", "代号", "长度", "数量") ActiveWorkbook.Worksheets("汇总2-字典").Sort.SortFields.Clear ActiveWorkbook.Worksheets("汇总2-字典").Sort.SortFields.Add Key:=Range("A8"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("汇总2-字典").Sort .SetRange Range("A2:D10") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With MsgBox "汇总报表用时" & s - Timer & "秒"End Sub

我用了120个工作簿做了测试，运行时间为69.58594秒！这效率有多高？

补充几点注意事项：

1.要在工作簿所在文件里新建一个工作簿，把这段代码放到VBE编辑器中，并存为.xlsm格式。

2.f = Dir(ThisWorkbook.Path &"\*test*.xlsx")

这句代码是用来识别你文件夹下文件名称的，其实中间的test没有必要写，我这是看每个文件的文件名都有test，才这样写的。写成：f = Dir(ThisWorkbook.Path & "\*.xlsx") 就行。

Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&

Set sh = ActiveSheet

MyPath = ThisWorkbook.Path & "\"

MyName = Dir(MyPath & "*.xls")

Application.ScreenUpdating = False

Cells.ClearContents