求一个将多个工作表合并在一个新工作表的VBA代码 感谢大神 由于我是小白 希望能有批注 谢谢 谢谢

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")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

网上也有很多工具

学习

用这个代码吧
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 = ThisWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls*")
AWbName = ThisWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("a65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 5)
For G = 1 To Wb.Sheets.Count
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("a65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

求问大神，怎么可以文件名对应sheet的方式来合并啊？

您好！正在找这种代码。这种合并对工作簿有什么要求吗？我的待合并工作簿是按月命名，如1月、2月、3月、4月、5月，还有上年末的0月，每簿只一个表，是从系统导出的，共83列，前四行是表头末四行是表尾是不需要合并的数据，中间二千多行是数据。合并工作簿中是四个表，分别是合并表、分类汇总表、数据透视表与图表，簿名是合并。合并表已按数据库标准预设了格式与字段，比各月份的工作簿多了一列，是84列，第84列用于记录月份，以区分每月的数据，并用作透视表的字段。我的要求是在合并表中粘贴各月数据时，在第84列增加一列月份，这在每月工作簿中是没有的，需另写代码，比如把各月簿名写入。