怎样编写一个VBA,快速将多个excel工作簿按相同名称的工作表分开汇总到一个新表格里。

Question

有多个excel工作簿，每个工作簿里面的工作表的名称相同，工作表排列的顺序相同，请问如何快速地将多个这样的工作簿按工作表名称汇总到一个新的工作簿里对应名称的工作表里。

Answer 1

'把要汇总的工作簿放在同一文件夹下，再建一个汇总工作簿，把下面代码放入汇总工作簿中。
Sub ABCD()
Dim lj As String
Dim dirname As String
Dim nm As String
lj = ActiveWorkbook.Path
nm = ActiveWorkbook.Name
dirname = Dir(lj & "\*.xls")
Cells.Clear
Do While dirname <> ""
If dirname <> nm Then
Workbooks.Open Filename:=lj & "\" & dirname
Workbooks(nm).Activate
Workbooks(dirname).Sheets(1).Range("A4:J15").Copy _
Sheets(1).Range("a65536").End(xlUp).Offset(1, 0)
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
Rows("1:1").Select
Selection.Delete Shift:=xlUp
End Sub追问

试了一下的确不错，可以将不同工作簿相同名字的表格合并在一个新工作的表格里。但是还有一点没有成功，就是每个工作簿里只能对一个工作表有效，我的每个工作簿里有很多个表要合并，请问有办法解决吗

追答

'修改如下：
'把要汇总的工作簿放在同一文件夹下，再建一个汇总工作簿，把下面代码放入汇总工作簿中。
Sub ABCD()
Dim lj As String
Dim dirname As String
Dim nm As String
For j = 1 To 4 '根据表数
Worksheets(j).Activate
Cells.Clear
Next
For i = 1 To 4 '根据表数
lj = ActiveWorkbook.Path
nm = ActiveWorkbook.Name
dirname = Dir(lj & "\*.xls")
Do While dirname ""
If dirname nm Then
Workbooks.Open Filename:=lj & "\" & dirname
Workbooks(nm).Activate
Workbooks(dirname).Sheets(i).Range("A4:J15").Copy _
Sheets(i).Range("a65536").End(xlUp).Offset(1, 0)
Workbooks(dirname).Close False
End If
dirname = Dir
Loop
Next
End Sub