Makro baucht zu lange (Not responding)

Sub CopyQualiStatus()

    Dim wsSource As Worksheet

    Dim wsTarget As Worksheet

    Dim rng As Range

    Dim cell As Range

    Dim i As Long

    

    'Mehr Performance?

    With Application

    .ScreenUpdating = False

    .Calculation = xlCalculationManual

    .EnableEvents = False

    End With



    'Arbeitsblätter setzen

    Set wsSource = ThisWorkbook.Sheets("alle Qualis gefiltert")

    Set wsTarget = ThisWorkbook.Sheets("Aktueller Quali-Status")



    'jede Zeile von "alle Qualis gefiltert" durchlaufen

    For Each cell In wsSource.Range("B2:B" & wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row)

        'jede Zeile von "aktueller Quali-Status" durchlaufen

        For i = 9 To wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row

            ' Wenn ID und Qualifikation übereinstimmen und in Spalte H nicht gleich Spalte G ist, in "alle Qualis gefiltert"

            If wsTarget.Cells(i, "C").Value = cell.Value And wsTarget.Cells(i, "F").Value = wsSource.Cells(cell.Row, "E").Value And wsTarget.Cells(i, "H").Value > wsSource.Cells(cell.Row, "G").Value Then

                wsSource.Cells(cell.Row, "I").Value = wsTarget.Cells(i, "H").Value

                ' Beenden Sie die Schleife, sobald eine Übereinstimmung gefunden wurde

                Exit For

            End If

        Next i

        ' Wenn keine Übereinstimmung gefunden wurde, lassen Sie die Zelle leer

        If wsSource.Cells(cell.Row, "I").Value = "" Then

            wsSource.Cells(cell.Row, "I").Value = ""

        End If

    Next cell

    

    'Mehr Performance?

    With Application

    .ScreenUpdating = True

    .Calculation = xlAutomatic

    .EnableEvents = True

    End With

    

    'Nachricht

    MsgBox "Der Vorgang wurde beendet.", vbInformation

    

End Sub