Speed up macro

Closed . Code not wrapped

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