一、问题
工作需要将多个小的excel文件合并成为一个excel文件,文件格式、内容一致,因为文件数目较多,不考虑手动粘贴复制,直接考虑使用VBA程序解决这个问题。
图1 同一个文件夹下的多个excel文件
二、代码
Sub 打开文件夹下所有文件并复制制定内容()
Dim a$, n As Long, i As Long, Num As Long, Name$ '定义n为计算写入的起始行号,Num为文件计数,n最好设为长整型,不然容易溢出Dim h% 'h定义为除首行(字段名)的内容行数
Dim mypath$
t = Timer
Application.ScreenUpdating = False
mypath = ActiveWorkbook.Path '获取当前宏文件所在问价夹路径
a = Dir(mypath & "\" & "*.xls") '获取当前文件夹下文件路径
Workbooks.Open mypath & "\" & a '遍历文件
Workbooks(a).Activate
i = Sheets("Sheet0").Range("a65536").End(xlUp).Row '这里.xls最大行数只能是65536
Workbooks(a).Sheets("Sheet0").Range("A2", "P" & i).Copy Workbooks("汇总").Sheets("汇总").Range("A2")
Workbooks("汇总").Sheets("汇总").Range("Q2", "Q" & i) = a
Workbooks(a).Close
Num = 1
Name = Left(a, Len(a) - 4)
Do
a = Dir
If a <> "" And a <> "汇总.xlsm" Then
Workbooks.Open mypath & "\" & a
n = Workbooks("汇总").Sheets("汇总").Range("a1048576").End(xlUp).Row + 1
Workbooks(a).Activate
i = Workbooks(a).Sheets("Sheet0").Range("a65536").End(xlUp).Row
Workbooks(a).Sheets("Sheet0").Range("A2", "P" & i).Copy Workbooks("汇总").Sheets("汇总").Range("A" & n)
Workbooks("汇总").Sheets("汇总").Range("Q" & n, "Q" & n + i - 2) = a
Workbooks(a).Close
Num = Num + 1
Name = Name & Left(a, Len(a) - 4)
' MsgBox "共合并:" & Num & "个文件!"
Else
MsgBox "共合并:" & Num & "个文件!" & "共用时:" & (Timer - t) & "s"
Exit Sub
End If
Loop
End Sub