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

jpb388 à dit:

Bonjour à tous
Regarde si cela te convient

VB:

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

Cliquez pour agrandir...

Bernard_XLD à dit:

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, @+

VB:

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

Cliquez pour agrandir...