VBA合并文件夹下多个文件并提取每个文件的文件名

一、问题

工作需要将多个小的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