Excel 合并当前目录下所有工作簿的全部工作表的VBA代码

本代码源自网络，不知作者是谁。我在分析完代码后，添加了注释，并修改了BUG。分享给大家，希望对大家有用。直接复制就可以运行了。

'#######################################################################################################
'使用说明:
'本代码涉及的文件有两类，一类是被合并的Excel文件，A1，A2...An可能有很多个；
'一类是合并后的文件B，只有一个，建议直接在目录下新建一个Excel文件操作合并；
'需要合并的文件和合并后的文件需要放置到同一个文件夹下；
'代码默认只能批量合并.xls格式文件，可以在第二行注释修改文件格式以合并xlsx格式Excel文件；
'代码批量将需要合并的Excel文件的各个sheet页一次性合并到执行代码的Excel文档的sheet页；
'如果当前执行代码的文件格式为xlsx格式,第七行注释下面的那一行的代码的A65536需要改成A1048576；
'#######################################################################################################

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName                 '第一行注释，声明变量
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False			'第二行注释，关闭实时显示执行效果
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "\" & "*.xls")    '第三行注释，遍历目录下全部格式为xls的Excel文件,如果Excel文件格式为xlsx，此处要将xls改成xlsx
    AWbName = ActiveWorkbook.Name           '第四行注释，保存当前Excel文件的文件名
    Num = 0
    Do While MyName <> ""
        If MyName <> AWbName Then
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
                Num = Num + 1   			'第五行注释，记录合并的Excel文件数量
            With Workbooks(1).ActiveSheet   '第六行注释，当前Excel工作簿的第一个sheet页
                For G = 1 To Wb.Sheets.Count
			'第七行注释，复制打开的Excel文件的sheet页到当前Excel文件，如果当前Excel文档为xlsx格式，此处需要将A65536改成A1048576
                    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
                Next
                WbN = WbN & Chr(13) & Wb.Name   '第八行注释，保存已合并的Excel文件，并还货
                Wb.Close SaveChanges:=False     '第九行注释，关闭打开的Excel文件并不保存，也可以写成:Wb.Close False或Wb.Close(False)
            End With
        End If
        MyName = Dir    '第十行注释，继续查找下一个满足条件的文件，再次调用dir函数时，不需要提供pathname参数和attributes参数
                        '第十一行注释，循环调用，直到返回的值为空时，表示没有再满足条件的文件存在。
    Loop
Range("A1").Select		'第十二行注释，执行完sheet页复制后，光标落在A1单元格
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub