Sub Button2_Click()
Dim Wkb As Workbook
Dim wbDest As Workbook, shtDest As Worksheet, source As Worksheet
Dim path As String, ThisWB As String, Filename As String
Dim CopyRng As Range, Dest As Range
Dim currLastrow As Long, prevlastrow As Long
On Error GoTo err_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
currLastrow = 2 ' Row to start on in the sheets you are copying from
ThisWB = ActiveWorkbook.Name
Set shtDest = ActiveWorkbook.Sheets(1)
path = GetDirectory("Select a folder containing Excel files you want to merge")
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "" & Filename)
Set source = Wkb.Sheets(1)
Set CopyRng = source.Range(source.Cells(currLastrow, 1), source.Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Dest = shtDest.Range("B" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
prevlastrow = currLastrow
currLastrow = shtDest.Cells(shdest.Rows.Count, "B").End(xlUp).Row
shdest.Cells(prevlastrow, "A").Resize(currLastrow - prevlastrow + 1).Value = Filename
End If
Filename = Dir()
Loop
shdest.Range("A1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Done!"
Exit Sub
GoTo err_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub