La gestion des doublons dans Excel

=ET(A1:A10=B1:B10)

Option Explicit

Sub Test()
    Creer_Liste_SansDoublons Range("A1:A20")
End Sub



Sub Creer_Liste_SansDoublons(Plage As Range)
    Dim Cell As Range
    Dim Un As Collection
    Dim i As Long
    
    Set Un = New Collection
    
    On Error Resume Next
    
    'Boucle sur la plage de cellule
    For Each Cell In Plage
        'If Cell <> "" Permet de ne pas prendre en compte les cellules vides
        'Un.Add Cell, CStr(Cell) Ajoute le contenu de la cellule dans la collection
        If Cell <> "" Then Un.Add Cell, CStr(Cell)
    Next Cell
    
    On Error GoTo 0
    
    'Boucle sur les éléments de la collection.
    For i = 1 To Un.Count
        'Ecrit le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print Un.Item(i)
    Next i

    Set Un = Nothing
End Sub

Dim Un As Collection
Set Un = New Collection

Un.Add Cell, CStr(Cell)

On Error Resume Next

'
'Un.Add Cell, CStr(Cell)
'

On Error GoTo 0

For i = 1 To Un.Count
    'Ecrit le résultat dans la fenêtre d'exécution (Ctrl+G)
    Debug.Print Un.Item(i)
Next i

Set Un = Nothing

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim Colonne As Integer
    Dim Adresse As String
    
    'On sort si plus d'une cellule a été modifiée
    If Target.Count > 1 Then Exit Sub
    'On sort si la cellule modifiée est vide
    If Target.Value = "" Then Exit Sub
    
    'Définit la colonne à vérifier (1=Colonne A, 2=colonne B ...etc...)
    Colonne = 1
    
    'Vérifie si c'est la colonne cible a été modifiée
    If Target.Column = Colonne Then
    
        'Recherche si la nouvelle donnée existe déjà dans la colonne.
        Adresse = Columns(Colonne).Find(What:=Target.Value, After:=Target.Offset(1, 0), LookAt:=xlWhole, _
            SearchDirection:=xlNext).Address
            
        'Si l'adresse de cellule trouvée ne correspond pas à la cellule modifiée, cela
        'signifie qu'il y a un doublon dans la colonne.
        If Adresse <> Target.Address Then
        
            MsgBox "La donnée '" & Target & "' existe déjà dans la cellule " & Adresse
            'Suppression de la donnée
            Target.Value = ""
            Target.Select
        
        End If
    End If
  
End Sub

Option Explicit
Option Base 1


Sub listeDoublonsPlage()
    Dim Plage As Range
    Dim Tableau(), Resultat() As String
    Dim i As Integer, j As Integer, m As Integer
    Dim Un As Collection
    Dim Doublons As String
        
    Set Un = New Collection
    'La plage de cellules (sur une colonne) à tester
    Set Plage = Range("A1:A" & Range("A65536").End(xlUp).Row)
      
      
    Tableau = Plage.Value
    
    On Error Resume Next
    'boucle sur la plage à tester
    For i = 1 To Plage.Count
    
        ReDim Preserve Resultat(2, m + 1)
        
        'Utilise une collection pour rechercher les doublons
        '(les collections n'acceptent que des données uniques)
        Un.Add Tableau(i, 1), CStr(Tableau(i, 1))
        
        'S'il y a une erreur (donc présence d'un doublon)
        If Err <> 0 Then
            
            'boucle sur le tableau des doublons pour vérifier s'il a déjà
            'été identifié
            For j = 1 To m + 1
                'Si oui, on  incrémente le compteur
                If Resultat(1, j) = Tableau(i, 1) Then
                    Resultat(2, j) = Resultat(2, j) + 1
                    Err.Clear
                    Exit For
                End If
            Next j
                
                'Si non, on ajoute le doublon dans le tableau
                If Err <> 0 Then
                    Resultat(1, m + 1) = Tableau(i, 1)
                    Resultat(2, m + 1) = 1
                    
                    m = m + 1
                    Err.Clear

                End If
        End If
    Next i

    '----- Affiche la liste et le nombre de doublons --------
    For j = 1 To m
        Doublons = Doublons & Resultat(1, j) & " --> " & _
                    Resultat(2, j) & vbCrLf
    Next j
    
    MsgBox Doublons
    
    Set Un = Nothing
End Sub

Option Explicit


Sub Test()
    CommunsPlages_CountIf Range("A6:A25"), Range("B1:B17")
End Sub



'La procédure recherche et compte les données de Plage_A qui apparaissent
'aussi dans Plage_B
Sub CommunsPlages_CountIf(Plage_A As Range, Plage_B As Range)
    Dim Cell As Range
    Dim i As Integer, k As Integer
    Dim Tableau() As Variant
    
    'boucle sur les cellules de la plage Plage_A
    For Each Cell In Plage_A
        
        'Vérifie si la donnée de Plage_A apparait dans Plage_B
        If Application.CountIf(Plage_B, Cell) > 0 Then
            'Redimensionne le tableau de résultats
            i = i + 1
            ReDim Preserve Tableau(1 To 2, 1 To i)
            
            'Compte le nombre de fois que la donnée apparait
            'dans Plage_B.
            k = Application.CountIf(Plage_B, Cell)
            
            '--- Remplissage tableau:
            'La donnée
            Tableau(1, i) = Cell
            'Le nombre de fois que la donnée apparait dans Plage_B.
            Tableau(2, i) = k
            '-----------------------
        End If
    Next Cell

    'Copie le tableau de résultats dans la Feuil2
    Worksheets("Feuil2").Range("A1:B" & i) = Application.Transpose(Tableau)
End Sub

Option Explicit


Sub Test()
    IdentifieDoublons Range("A1:C20")
End Sub



Sub IdentifieDoublons(Plage As Range)
    Dim Cell As Range
    Dim Un As Collection
    
    Set Un = New Collection
  
    On Error Resume Next
    
    'Boucle sur la plage de cellule
    For Each Cell In Plage
        'Pour ne pas prendre en compte les cellules vides
        If Cell <> "" Then
            'Ajoute le contenu de la cellule dans la collection
            Un.Add Cell, CStr(Cell)
            
            'Si la procédure renvoie une erreur, cela signifie que l'élément
            'existe déjà dans la collection et donc qu'il s'agit d'un doublon.
            'Dans ce cas la macro colorie la cellule en vert.
            If Err <> 0 Then Cell.Interior.ColorIndex = 4
            'Efface toutes les valeurs de l'objet Err.
            Err.Clear
        End If
    Next Cell
    
    Set Un = Nothing    
End Sub

'Excel 2007
With Range("A1:A10")
    .FormatConditions.AddUniqueValues
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    'Utilisez xlUnique pour identifier les valeurs uniques
    .FormatConditions(1).DupeUnique = xlDuplicate
    .FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End With

Sub FiltreDoublons()
    Dim Plage As Range
    
    'Définit la plage à filtrer (A1 correspond à l'entête et
    'ne sera pas pris en compte dans le filtre)
    Set Plage = Range("A1:C10")
    
    'La plage filtrée sans doublons  va s'afficher
    'dans la cellule H1.
    Plage.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("H1"), Unique:=True
End Sub

Option Explicit

Sub Test()
    'Supprime les doublons dans la colonne B
    SuppressionDoublonColonne 2
End Sub



Sub SuppressionDoublonColonne(NumCol As Integer)
    Dim Cible As Range, Suivant As Range
        
    Application.ScreenUpdating = False
    
    With Columns(NumCol)
        .Cells(1, 1).Sort Key1:=.Cells(1, 1), Order1:=xlAscending
      
        Set Cible = .Cells(1, 1)
          
        Do
            Set Suivant = Cible.Offset(1, 0)
            
            If Suivant = Cible Then Cible.Delete xlUp
            Set Cible = Suivant
        Loop Until Cible = ""
    End With
    
    Application.ScreenUpdating = True
End Sub

Option Explicit
Option Base 1


Sub SupprimeDoublons()
Dim Plage As Range, Cell As Range
Dim Un As Collection
Dim Tableau() As Long
Dim x As Integer


Set Un = New Collection
    
Set Plage = Worksheets("Feuil1").Range("A1:A10")

For Each Cell In Plage
    On Error Resume Next
    'Alimente la collection de données sans doublons.
    Un.Add Cell, CStr(Cell)
    
    'Une erreur survient si l'élément existe dans la collection.
    'La procédure enregistre le numéro de ligne correspondant dans un tableau.
    If Err.Number <> 0 Then
        x = x + 1
        ReDim Preserve Tableau(x)
        Tableau(x) = Cell.Row
    End If
Next Cell


'On sort de la procédure s'il n'y a pas de doublons.
If x = 0 Then Exit Sub

'Permet de figer l'écran pendant la suppression des lignes.
Application.ScreenUpdating = False

'boucle sur le tableau pour supprimer les lignes contenant les doublons.
For x = UBound(Tableau) To LBound(Tableau) Step -1
    Worksheets("Feuil1").Rows(Tableau(x)).EntireRow.Delete
Next x

Application.ScreenUpdating = True
MsgBox "Terminé."

Set Un = Nothing
End Sub

Sub SuppressionDoublons_Excel2007()
'Header:=xlYes
'permet de spécifier que la 1ere ligne correspond à un entête

'Columns:=Array(1, 3)
'Définit la ou les colonnes à prendre en compte pour identifier les doublons

'Supprime les données dans la plage A1:C10 si les enregistrements des colonnes A et C
'forment un doublon. 
Worksheets("Feuil1").Range("A1:C10").RemoveDuplicates _
    Columns:=Array(1, 3), Header:=xlYes
End Sub

Private Sub UserForm_Initialize()
    Dim i As Integer
    
    'Boucle sur les cellule de la colonne A
    For i = 1 To Range("A65536").End(xlUp).Row
        
        'Remplit la zone d'édition du ComboBox
        ComboBox1 = Range("A" & i)
        
        'ComboBox1.ListIndex renvoie -1 si la donnée n'existe pas dans
        'la liste déroulante. Dans ce cas, on va pouvoir utiliser la méthode AddItem
        'pour intégrer la donnée dans le ComboBox.
        '(Range("A" & i) <> "" permet simplement de gérer les éventuelles cellules vides
        'dans la colonne A).
        If ComboBox1.ListIndex = -1 And Range("A" & i) <> "" Then _
            ComboBox1.AddItem Range("A" & i)
    Next i
End Sub

Sub Test()
    GenereSerieAleatoireSansDoublons 25, Range("B1")
End Sub


Sub GenereSerieAleatoireSansDoublons(NbValeurs As Integer, Cell As Range)
    Dim Tableau() As Integer, TabNumLignes() As Integer
    Dim i As Integer, k As Integer
    
    ReDim Tableau(NbValeurs)
    ReDim TabNumLignes(NbValeurs)
    
    For i = 1 To NbValeurs
        TabNumLignes(i) = i
        Tableau(i) = i
    Next
    
    'Initialise le générateur de nombres aléatoires
    Randomize
    
    For i = NbValeurs To 1 Step -1
        k = Int((i * Rnd) + 1)
        Cells(Cell.Row + i - 1, Cell.Column) = Tableau(TabNumLignes(k))
        TabNumLignes(k) = TabNumLignes(i)
    Next

End Sub

Option Explicit


Sub Test()
    'Inscrit une série de 20 valeurs aléatoires dans la colonne, à partir
    'de la cellule A1.
    'Les valeurs aléatoires seront comprises entre 1 et 150.
    SerieAleatoire Range("A1"), 150, 20
End Sub


Sub SerieAleatoire(Cellule As Range, ValMaxi As Integer, NbVal As Integer)
    Dim i As Integer
    
    Randomize
    
    Cellule = Int(ValMaxi * Rnd + 1)
    
    For i = 1 To NbVal - 1
        Do
        Cellule.Offset(i, 0) = Int(ValMaxi * Rnd + 1)
        Loop Until Application.IsNA(Application.Match _
            (Cellule.Offset(i, 0), Cellule.Resize(i, 1), 0))
    Next i

End Sub