I am trying to speed up this macro that I have. Maybe get rid of the Activation and Select. And any other methods to speed it up will be greatly appreciate. Here is the code in question:


Sub AllFolderFiles()

Application.DisplayAlerts = False
Dim wb As Workbook
Dim TheFile As String
Dim MyPath As String

MyPath = "C:\Documents and Settings\Owner\Desktop\upperdata300Loop"
ChDir MyPath
TheFile = Dir("*.xlsx")
Do While TheFile <> ""
Set wb = Workbooks.Open(MyPath & "\" & TheFile)
wb.Activate
Range("a1").CurrentRegion.Copy
wb.Close
Range("a2").Select
ActiveSheet.Paste
ActiveSheet.Range("$A$1:$PG$1643").AutoFilter Field:=6, Criteria1:="1"
Range("a1").CurrentRegion.Copy
Windows("results.xlsx").Activate
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Windows("UpperCompare 001.xlsx").Activate
ActiveSheet.Range("$F$1:$ATG$500").AutoFilter Field:=6
Range("A2:D400").Select
Selection.ClearContents

TheFile = Dir
Loop
End Sub

Eric

Try to place this code under macro name

Application.ScreenUpdating = False


And place this code before End sub

Change these 3 line below

to

Range("a1").CurrentRegion.Copy
Application.goto Workbooks("results.xlsx").Sheets("YourSheetName"). Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).

I do not sure that

Will work but please try on.

Change thess 2 lines Code
to
N. Yauvasuta