Makro zu langsam

Sub UpdateDateienEinspielen()


    Application.ScreenUpdating = False
 
Dim wksDiesesSheet As Worksheet
Set wksDiesesSheet = ActiveSheet
wksDiesesSheet.Outline.ShowLevels RowLevels:=2


'Überschreiben der alten Werte durch neuen
    Range("AG5:AK1100").Select
    Selection.Copy
    Range("AA5").Select
    ActiveSheet.Paste


Dim wksQuelle As Object
Dim lastrow As Long
Dim ID As Variant
Dim Stufen As Range
Dim NeueZahlen As Range
Dim Kommentare As Range




            'Auswählen der Update Dateien
               'Defines the variable as a variant data type
                Dim X As Variant

                'Opens the dialog
                SpeicherPfad = ThisWorkbook.Path & "\"
                ChDir SpeicherPfad

                 X = Application.GetOpenFilename _
                        ("Excel-Datei (*.xls), *.xls, Add-in Files (*.xls), *.xls", 2, _
                        "Open My Files", , True)


             'Loops through every file that is selected and opens each one
               For Y = 1 To UBound(X)
                   Workbooks.Open X(Y)
                   Set wksQuelle = GetObject(X(Y))


            lastrow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

            For i = 6 To lastrow 'gehe durch alle befüllten Zeilen in der Update datei


                wksQuelle.Activate 'Aktiviere Update Datei

                If Cells(i, 6).Value = "3" Then
                ID = Cells(i, 3).Value
                Set Stufen = Range(Cells(i, 22), Cells(i, 26)) 'kopiere Stufen
                Set NeueZahlen = Range(Cells(i, 41), Cells(i, 44)) 'kopiere Neue Zahlen
                Set Kommentare = Range(Cells(i, 46), Cells(i, 47)) 'kopiere Kommentare


                wksDiesesSheet.Activate 'gehe in Master Sheet


                Columns("B:B").Select
                Selection.Find(What:=ID, After:=ActiveCell, LookIn:=xlValues, LookAt _
                :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Select
                Zeile_Master = Selection.Row
                Stufen.Copy Range(Cells(Zeile_Master, 15), Cells(Zeile_Master, 19)) 'fuege Stufen ein
                NeueZahlen.Copy Range(Cells(Zeile_Master, 34), Cells(Zeile_Master, 37)) 'füge New Forecast ein
                Kommentare.Copy Range(Cells(Zeile_Master, 39), Cells(Zeile_Master, 40)) 'fuege Kommentare ein
                End If

            Next i
        wksQuelle.Close
    Next Y
 
End Sub