VBA:合并同一文件夹下的所有表

一、代码需求

二、代码示例

Sub 合同同一文件夹下的所有表()
Dim r As Long, c As Long
r = 1
c = 3    'c的值是为了控制有几列，可以根据实际情况调整
Range(Cells(r, "A"), Cells(65536, c)).ClearContents  '合并前先清空所在表
Application.ScreenUpdating = False
Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, fn As String, arr As Variant, flag As Integer
filename = Dir(ThisWorkbook.Path & "\*.xls")   '获取该文件夹下的所有表的表名
flag = 1
Do While filename <> ""
If filename <> ThisWorkbook.Name Then   '为了避免合并的总表自己调用自己
If flag = 1 Then
erow = 1
Else
erow = Range("A1").CurrentRegion.Rows.Count + 1    '为了找出要粘贴到汇总表的位置
End If
fn = ThisWorkbook.Path & "\" & filename
Set wb = GetObject(fn)        '在后台打开一张表
Set sht = wb.Worksheets(1)    '只合并该工作簿中的第一张表
If flag = 1 Then       '该flag是为避免重复复制表头而设置
arr = sht.Range(sht.Cells(r, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 9))    'arr找到要复制的区域，运行此句时含表头
Else
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 9))  'arr找到要复制的区域，运行此句时不含表头
End If
Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr   'UBound(arr, 1)计算出行数，UBound(arr, 2)计算出列数
wb.Close False     '将刚才打开的表关闭
End If
filename = Dir     '运行此句时filename获取下一个表的表名
flag = 2
Loop
Application.ScreenUpdating = True

End Sub

三、运行结果

四、说明