Excel VB Makro - Suchen und Ersetzen zwischen 3 Tabellen

Sub Datenübernahme()
    Dim shCOR As Worksheet, shPRO As Worksheet, shVER As Worksheet, shREPARATUR As Worksheet, colKeineMängel As New Collection, colReparaturErforderlich As New Collection
    Dim c As Range, firstAddress As String, itm As Variant, tbl As Variant, col As Variant
    
    Set shCOR = Sheets("COR")  
    Set shPRO = Sheets("PRO")  
    Set shVER = Sheets("VER")  
    Set shREPARATUR = Sheets("REP")  
    
    MsgBox "Datenübernahme gestartet...", vbInformation  
    With shCOR
        Set rngSearch = .Range("D2:D" & .Cells(Rows.Count, "D").End(xlUp).Row)  
        ' Suche "Keine Mängel"  
        Set c = rngSearch.Find("Keine Mängel", LookIn:=xlValues)  
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                colKeineMängel.Add c.Offset(0, -3).Resize(1, 6)
                Set c = rngSearch.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
        ' Suche "Reparatur erforderlich"  
        Set c = rngSearch.Find("Reparatur erforderlich", LookIn:=xlValues)  
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                colReparaturErforderlich.Add c.Offset(0, -3).Resize(1, 6)
                Set c = rngSearch.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    
    For Each tbl In Array(shPRO, shVER)
        With tbl
            Set rngSearch = .Range("A8:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            For Each col In Array(colKeineMängel, colReparaturErforderlich)
                For Each itm In col
                    Set c = rngSearch.Find(itm.Cells(1, 1).Value, LookIn:=xlValues)
                    If Not c Is Nothing Then
                        firstAddress = c.Address
                        Do
                            itm.Copy Destination:=c
                            If itm.Cells(1, 4).Value = "Reparatur erforderlich" Then  
                                c.EntireRow.Interior.Color = vbRed
                            End If
                            Set c = rngSearch.FindNext(c)
                        Loop While Not c Is Nothing And c.Address <> firstAddress
                    End If
                Next
            Next
        End With
    Next
    For Each itm In colReparaturErforderlich
    Set rngDest = shREPARATUR.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
        itm.Copy Destination:=rngDest
        rngDest.EntireRow.Interior.Color = vbRed
    Next
    MsgBox "Datenübernahme erfolgreich abgeschlossen!", vbInformation  
End Sub