Fusionner des tableaux de 3000 contacts - Besoin d'aide SVP !

Sub Retraitement()
Application.ScreenUpdating = False
Application.Calculation = xlManual

    Dim Cel As Range
    Dim myRange As Range
    Set myRange = Range("A3:A" & Range("A65536").End(xlUp).Row) 'Colonne où se trouvent les prénoms, le [A3] représente la cellule de la première valeur de ta base de données (Hors entêtes)
    For Each Cel In myRange
    
    Dim i&
    For i = Cel.Row + 1 To Range("A65536").End(xlUp).Row
    
        If Cel.Value & Cel.Offset(0, 1).Value = Range("A" & i).Value & Range("B" & i).Value Then
            
            Dim k&
            For k = 1 To 2 'Nombres d'évents [Nombres de colonnes après sociétées]
            
            If Cells(i, k + 3).Value <> "" Then
            Cel.Offset(0, k + 2).Value = Cells(i, k + 3).Value
            End If
            
            Next k
            
        Range("A" & i).EntireRow.Interior.ColorIndex = 3
        End If
        
    Next i
    Next Cel
    
Dim j&
For j = Range("A65536").End(xlUp).Row To 3 Step -1 ' Le 3 représente la ligne de la première valeur de ta base de données (Hors entêtes)

    If Range("A" & j).Interior.ColorIndex = 3 Then
    Rows(j).Delete
    End If
    
Next j
    
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

End Sub