XL 2016 Comparer et Supprimer si codes répétés

[KTM]

Bonsoir chers tous
Je veux vérifier et supprimer les codes de ma plage 2 qui se retrouvent aussi dans ma plage 1.
J'ai bricolé la macro qui suit et qui fonctionne bien.
Mais je voudrais savoir si quelqu'un pouvait me proposer mieux et rapide au cas ou je serais face à des données importantes
Merci

 

[jpb388]

Bonjour à tous
Regarde si cela te convient

Sub SupprimerDoublons()
      
      Dim Dico As Object
      Dim Pl As Range, Cel As Range, Lg%
      Set Dico = CreateObject("Scripting.Dictionary")
      Lg = Range("A" & Rows.Count).End(xlUp).Row
      Set Pl = Range("A2:A" & Lg)
      Application.ScreenUpdating = False
      For Each Cel In Pl
            If Not Dico.exists(Cel.Text) Then Dico.Add Cel.Text, ""
      Next Cel
      Lg = Range("F" & Rows.Count).End(xlUp).Row
      Set Pl = Range("F2:F" & Lg)
      For Lg = Lg To 2 Step -1
           If Dico.exists(Pl(Lg - 1).Text) Then Range("F" & Lg & ":H" & Lg).Delete Shift:=xlUp
      Next Lg
      Application.ScreenUpdating = True
End Sub

 

[Bernard_XLD]

Bonjour KTM, jpb388, le forum

Sur de grandes séries de données en valeurs, il sera plus rapide de passer par des tableaux Vb et de supprimer les lignes non utilisées en 1 fois, si leur suppression, une fois vidées et en fin de tableau, reste nécessaire. C'est très rapide sans avoir besoin de désactiver l'affichage écran ou le calcul automatique.

Bien cordialement, @+

Sub Traitement_Doublons()
    Dim Dico_Valeurs As Object, Tablo, Tablo2(), x&, y&, z&, Tablo_Ref1
    Set Dico_Valeurs = CreateObject("Scripting.Dictionary")
    Tablo = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
    For x = LBound(Tablo, 1) To UBound(Tablo, 1)
        If Not Dico_Valeurs.exists(Tablo(x, 1)) Then Dico_Valeurs.Add Tablo(x, 1), ""
    Next x
    Set Tablo_Ref1 = Range("F2:H" & Range("F" & Rows.Count).End(xlUp).Row)
    Tablo = Tablo_Ref1.Value2
    ReDim Tablo2(LBound(Tablo, 1) To UBound(Tablo, 1), LBound(Tablo, 2) To UBound(Tablo, 2))
    y = LBound(Tablo, 1) - 1
    For x = LBound(Tablo, 1) To UBound(Tablo, 1)
        If Not Dico_Valeurs.exists(Tablo(x, 1)) Then
            y = y + 1
            For z = LBound(Tablo, 2) To UBound(Tablo, 2)
                Tablo2(y, z) = Tablo(x, z)
            Next z
        End If
    Next x
    Tablo_Ref1.Value2 = Tablo2
    ''à enlever si suppression des lignes vides non nécessaire
        If y < UBound(Tablo2, 1) Then
            Range("F" & 2 + y & ":H" & 1 + UBound(Tablo2, 1)).Delete Shift:=xlUp
        End If
    ''
End Sub

 

[KTM]

Bonjour à tous
Regarde si cela te convient

Sub SupprimerDoublons()
     
      Dim Dico As Object
      Dim Pl As Range, Cel As Range, Lg%
      Set Dico = CreateObject("Scripting.Dictionary")
      Lg = Range("A" & Rows.Count).End(xlUp).Row
      Set Pl = Range("A2:A" & Lg)
      Application.ScreenUpdating = False
      For Each Cel In Pl
            If Not Dico.exists(Cel.Text) Then Dico.Add Cel.Text, ""
      Next Cel
      Lg = Range("F" & Rows.Count).End(xlUp).Row
      Set Pl = Range("F2:F" & Lg)
      For Lg = Lg To 2 Step -1
           If Dico.exists(Pl(Lg - 1).Text) Then Range("F" & Lg & ":H" & Lg).Delete Shift:=xlUp
      Next Lg
      Application.ScreenUpdating = True
End Sub

impeccable !!!
Merci.

 

[KTM]

Bonjour KTM, jpb388, le forum

Sur de grandes séries de données en valeurs, il sera plus rapide de passer par des tableaux Vb et de supprimer les lignes non utilisées en 1 fois, si leur suppression, une fois vidées et en fin de tableau, reste nécessaire. C'est très rapide sans avoir besoin de désactiver l'affichage écran ou le calcul automatique.

Bien cordialement, @+

Sub Traitement_Doublons()
    Dim Dico_Valeurs As Object, Tablo, Tablo2(), x&, y&, z&, Tablo_Ref1
    Set Dico_Valeurs = CreateObject("Scripting.Dictionary")
    Tablo = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value2
    For x = LBound(Tablo, 1) To UBound(Tablo, 1)
        If Not Dico_Valeurs.exists(Tablo(x, 1)) Then Dico_Valeurs.Add Tablo(x, 1), ""
    Next x
    Set Tablo_Ref1 = Range("F2:H" & Range("F" & Rows.Count).End(xlUp).Row)
    Tablo = Tablo_Ref1.Value2
    ReDim Tablo2(LBound(Tablo, 1) To UBound(Tablo, 1), LBound(Tablo, 2) To UBound(Tablo, 2))
    For x = LBound(Tablo, 1) To UBound(Tablo, 1)
        If Not Dico_Valeurs.exists(Tablo(x, 1)) Then
            y = y + 1
            For z = LBound(Tablo, 2) To UBound(Tablo, 2)
                Tablo2(y, z) = Tablo(x, z)
            Next z
        End If
    Next x
    Tablo_Ref1.Value2 = Tablo2
    ''à enlever si suppression des lignes vides non nécessaire
        If y < UBound(Tablo2, 1) Then
            Range("F" & 2 + y & ":H" & 1 + UBound(Tablo2, 1)).Delete Shift:=xlUp
        End If
    ''
End Sub

Super !!
Merci.