VBA merges multiple files under a folder and extracts the file name of each file

First, the problem

Work needs to merge multiple small excel files into one excel file, the file format and content are consistent, because there are many files, do not consider manual paste and copy, directly consider using VBA program to solve this problem.

                                                            Figure 1 Multiple excel files in the same folder

Second, the code

Sub Open all files in the folder and copy the specified content ()

Dim a $, n As Long, i As Long, Num As Long, Name $    'Define n as the starting line number for writing, Num as the file count, n is best set as a long integer, otherwise it is easy to overflow
Dim h % 'h is defined as the number of content lines except the first line (field name)
Dim mypath $
t = Timer
Application.ScreenUpdating = False
mypath = ActiveWorkbook.Path ' Get the inquiry folder path where the current macro file is located
a = Dir (mypath & "\ "&" * .xls ") 'Get the file path of the current folder
Workbooks.Open mypath &" \ "& a' Traverse the file
Workbooks (a) .Activate
i = Sheets (" Sheet0 "). Range (" a65536 ") .End (xlUp) .Row 'Here. The maximum number of lines in xls can only be 65536
Workbooks (a) .Sheets ("Sheet0"). Range ("A2", "P" & i) .Copy Workbooks ("Summary") .Sheets ("Summary"). 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     MsgBox "Together:" & Num & "Files! "&" When sharing: "& (Timer-t) &" s "  Else 'MsgBox "Together:" & Num & "Files!"     Name = Name & Left (a, Len (a)-4)
    Num = Num + 1




    Exit Sub
 End If
Loop
End Sub