Code not copying range from all sheet in folder

[scassells]

Only paste the values from the first workbook and then it appears to not locate the next open row??

Sub Loopthrudirectory()
Dim myfile As String
Dim erow
myfile = Dir("C:\AA_HISTORY")

Do While Len(myfile) > 0
If myfile = "activity Log.xlsm" Then
Exit Sub
End If
Workbooks.Open (myfile)
Range("ak4:AT13").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Offset(3, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 2), Cells(erow, 11))
myfile = Dir
Loop

End Sub

 

[dmt32]

Hi welcome to forum

I suspect part of your problem is this part of your code

If myfile = "activity Log.xlsm" Then
Exit Sub
End If

which will exit the code if the file exists in the specified folder.

Try this update & see if it does what you want

Sub Loopthrudirectory()
    Dim myfile As String, mypath As String
    Dim Wb As Workbook
    Dim wsDest As Worksheet
    
    mypath = "C:\AA_HISTORY\"
    myfile = Dir(mypath & "*xl*")
    
    Set wsDest = ThisWorkbook.Worksheets("Sheet1")
    
    Application.ScreenUpdating = False
    Do While Len(myfile) > 0
    If myfile <> "activity Log.xlsm" Then
        Set Wb = Workbooks.Open(mypath & myfile, False, True)
        Wb.Sheets(1).Range("AK4:AT13").Copy _
        wsDest.Cells(wsDest.Cells(wsDest.Rows.Count, 3).End(xlUp).Offset(3, 0).Row, 2)
        Wb.Close False
    End If
    
    Set Wb = Nothing
    myfile = Dir
Loop


    Application.ScreenUpdating = True
End Sub

Dave

 

[scassells]

I have since modified the code and so 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

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

 

[scassells]

my code did not work but your did. Thanks