Comparer 2 colonnes sur feuil 1 et feuil 3

Dim Dico2 As Object, Dico3 As Object, Dico4 As Object  
Sub comparer_1234()  
Dim derlig1 As Long, cle  
Dim T_in  
Dim start As Single  

start = Timer  
'---initialisations  
With Sheets(1)  
     Application.ScreenUpdating = False  
     derlig1 = .Columns("A").Find("*", , , , , xlPrevious).Row  
     T_in = Application.Transpose(.Range("A1:A" & derlig1).Value)  
' création des dictionnaires feuilles 2,3,4  
     creer_dicos 2, Dico2  
     creer_dicos 3, Dico3  
     creer_dicos 4, Dico4  

'----détection et suppression des doublons intercolonnes  
     For cptr = 1 To UBound(T_in)  
          cle = .Cells(cptr, 1)  
          If Dico2.exists(cle) Then Dico2.Remove (cle)  
          If Dico2.exists(cle) Then Dico3.Remove (cle)  
          If Dico2.exists(cle) Then Dico4.Remove (cle)  
     Next  
 End With  
'----restitutions des feuilles épurées  
     '---RESTITUTIONS PROVISOIRE COLONNE B POUR ESSAIS  
   Sheets(2).Range("B1").Resize(Dico2.Count, 1) = Application.Transpose(Dico2.keys)   
   Sheets(3).Range("B1").Resize(Dico3.Count, 1) = Application.Transpose(Dico3.keys) 
   Sheets(4).Range("B1").Resize(Dico4.Count, 1) = Application.Transpose(Dico4.keys)  
     
   '--- LIGNES A ACTIVER APRES ESSAIS  
   'With Sheets(2)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico2.Count, 1) = Application.Transpose(dico2.keys)  
   'End With  
   'With Sheets(3)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico3.Count, 1) = Application.Transpose(dico3.keys)  
   'End With  
   'With Sheets(4)  
     '.Columns("A").ClearContents  
    ' .Range("A1").Resize(Dico4.Count, 1) = Application.Transpose(dico4.keys)  
   'End With  
       
MsgBox " suppression des occurences communes terminée en " & Timer - start & " .sec"  
End Sub  

Sub creer_dicos(Num, Dico)  
Dim derlig As Long  
Set Dico = CreateObject("scripting.dictionary")  
With Sheets(Num)  
     derlig = .Columns("A").Find("*", , , , , xlPrevious).Row  
     For cptr = 1 To derlig  
          Dico.Add .Cells(cptr, 1).Value, 1  
     Next  
End With  
End Sub  

Sub SupprimeDoublonsColonneA()  
'Sources d'inspiration:  
'boisgontierjacques : 
    'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm#SupDoubBD  
'Michel_m :
    'http://www.commentcamarche.net/forum/affich-24145736-comparer-2-colonnes-sur-feuil-1-et-feuil-3#11  
Dim Dico, CleDico  
Dim TablFeuil1, TablAutresFeuilles  
Dim DrLig As Long, i As Long  
Dim Wsh As Worksheet  
Dim t  

t = Timer  
Application.ScreenUpdating = False  
Set Dico = CreateObject("Scripting.Dictionary")  
With Sheets("Feuil1")  
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row  
    TablFeuil1 = Application.Transpose(.Range("A1:A" & DrLig).Value)  
    For i = 1 To UBound(TablFeuil1)  
        Dico(TablFeuil1(i)) = ""  
    Next i  
End With  
For Each Wsh In ThisWorkbook.Worksheets(Array("Feuil2", "Feuil3", "Feuil4"))  
    With Sheets(Wsh.Name)  
        DrLig = .Range("A" & Rows.Count).End(xlUp).Row  
        TablAutresFeuilles = Application.Transpose(.Range("A1:A" & DrLig).Value)  
        For i = UBound(TablAutresFeuilles) To 1 Step -1  
            CleDico = TablAutresFeuilles(i)  
            If Dico.Exists(CleDico) Then  
                .Rows(i).Delete  
            End If  
        Next i  
    End With  
Next Wsh  
MsgBox "Suppression terminée en : " & Timer - t & " secondes"  
Set Dico = Nothing  
End Sub  

Option Explicit 

Sub SupprimeDoublonsColonne1Version2() 

'Sources d'inspiration: 
'boisgontierjacques : 
    'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm#SupDoubBD 
'Michel_m : 
    'http://www.commentcamarche.net/forum/affich-24145736-comparer-2-colonnes-sur-feuil-1-et-feuil-3#11 
'FAQ XLD : 
    'http://www.excel-downloads.com/forum/93353-vba-les-tableaux-le-ki-ki-de-zon.html 

Dim Dico, CleDico 
Dim TablFeuil1, TablAutresFeuilles 
Dim DrLig As Long, i As Long 
Dim Wsh As Worksheet 
Dim t 

t = Timer 
Application.ScreenUpdating = False 
Set Dico = CreateObject("Scripting.Dictionary") 
With Sheets("Feuil1") 
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row 
    TablFeuil1 = .Range("A1:A" & DrLig) 
    For i = 1 To UBound(TablFeuil1, 1) 
        Dico(TablFeuil1(i, 1)) = "" 
    Next i 
End With 
For Each Wsh In ThisWorkbook.Worksheets(Array("Feuil2", "Feuil3", "Feuil4")) 
    With Sheets(Wsh.Name) 
        DrLig = .Range("A" & Rows.Count).End(xlUp).Row 
        TablAutresFeuilles = .Range("A1:A" & DrLig) 
        For i = UBound(TablAutresFeuilles, 1) To 1 Step -1 
            CleDico = TablAutresFeuilles(i, 1)
            If Dico.Exists(CleDico) Then 
                .Rows(i).Delete 
            End If 
        Next i 
    End With 
Next Wsh 
MsgBox "Suppression terminée en : " & Timer - t & " secondes" 
Set Dico = Nothing 
End Sub