同一文件夹下怎样将多个Excel表汇总到一个表里面

JUN2028

我平时的做法是先一个个复制粘贴到汇总表里，再删除不需要的列和行，由于实际操作中表格数量和内容都很多，工作效率太低了，想求助更简单的方法，最重要的是汇总到一个表中。

花~世界格~不入

使用前你需要把excel宏文件放到需要合并的文件夹中
备注：合并的excel文件包括  .xls 和.xlsx
直接上代码：
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

chxw68

1. Sub test()
   
2.   Dim r&, i&, m&
   
3.   Dim arr, brr(1 To 10000, 1 To 6)
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   mypath = ThisWorkbook.Path & ""
   
10.   myname = Dir(mypath & "*.xlsx")
    
11.   m = 0
    
12.   Do While myname <> ""
    
13.     If myname <> ThisWorkbook.Name Then
    
14.       Set wb = GetObject(mypath & myname)
    
15.       With wb
    
16.         With .Worksheets(1)
    
17.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.           arr = .Range("a2:x" & r)
    
19.           For i = 1 To UBound(arr)
    
20.             m = m + 1
    
21.             brr(m, 1) = arr(i, 2)
    
22.             brr(m, 2) = arr(i, 3)
    
23.             brr(m, 3) = arr(i, 5)
    
24.             brr(m, 4) = arr(i, 6)
    
25.             brr(m, 5) = arr(i, 7)
    
26.             brr(m, 6) = arr(i, 12)
    
27.           Next
    
28.         End With
    
29.         .Close False
    
30.       End With
    
31.     End If
    
32.     myname = Dir
    
33.   Loop
    
34.   With Worksheets("sheet1")
    
35.     .UsedRange.Offset(1, 0).ClearContents
    
36.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
37.   End With
    
38. End Sub
    

复制代码

chxw68

详见附件。

JUN2028

花~世界格~不入 发表于 2018-1-26 17:02
使用前你需要把excel宏文件放到需要合并的文件夹中
备注：合并的excel文件包括  .xls 和.xlsx
直接上代码 ...

非常感谢，对我帮助很大，还有一个问题想寻求帮助，同一工作簿如何汇总多个表格？

JUN2028

chxw68 发表于 2018-1-26 17:04
详见附件。

这个方法就是我想要的，运行后和您不一样的是没有标题，不过不影响。还有一个问题请教，同一工作簿里如何汇总多个工作表呢？好像积分不够，您的小花后面补上，非常感谢！

LMY123

多薄单表指定列合并（合并指定的字段名）

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim ws As Worksheet
   
4.   With Worksheets("汇总")
   
5.     .UsedRange.Offset(1, 0).Clear
   
6.   End With
   
7.   For Each ws In Worksheets
   
8.     If ws.Name <> "汇总" Then
   
9.       With ws
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
12.         With Worksheets("汇总")
    
13.           r0 = .Cells(Worksheets("汇总").Rows.Count, 2).End(xlUp).Row + 1
    
14.         End With
    
15.         .Range("a3").Resize(r - 2, c).Copy Worksheets("汇总").Cells(r0, 2)
    
16.         .Range("a1").Copy Worksheets("汇总").Cells(r0, 1).Resize(r - 2, 1)
    
17.       End With
    
18.     End If
    
19.   Next
    
20. End Sub
    

复制代码

chxw68

详见附件。

268906

chxw68 发表于 2018-1-26 17:04
详见附件。

我用你的代码改了一下 运行到200个文件时 无法运行了怎么解