Macro does not copy to the next row on the destination sheet

The following code does successfully loop through all of thesheets in the directory however it does not paste to the next open row in thedestination sheet and instead clobbers the data in the same rows

Can you assist?



Sub copydatafrommulttomaster()
Dim folderpath As String, Filepath As String, filename AsString
folderpath = "C:\Users\Stvcass\Documents\AA_HISTORY"
Filepath = folderpath & "*.xls*"
filename = Dir(Filepath)
Do While filename <> ""
If myfile = "activity Log.xlsm" Then
Exit Sub
End If
Workbooks.Open (folderpath & filename)
Application.DisplayAlerts = False
Range("AK4:AT15").Select
Range("AK4:AT15").Copy
'Application.DisplayAlerts = False
Activewookbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).Row
ActiveSheet.PasteDestination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow,4))
filename = Dir
Loop
Application.DisplayAlerts = True

End Sub

welcome to the forum.

try

Code:

---

Sub vbax_63379_copy_paste()

    Dim fPath As String, fName As String
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    fPath = "C:\Users\Stvcass\Documents\AA_HISTORY\" '\ (trailing backslash)
    fName = Dir(fPath & "*.xls*")
   
    Do While fName <> "" And fName <> "activity Log.xlsm"
        Workbooks.Open (fPath & fName)
        ActiveSheet.Range("C1:C7").Copy
        ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
        ActiveWorkbook.Close False
        fName = Dir
    Loop

End Sub

---