Option Explicit
Option Base 1
 
Sub SupprimeDoublons()
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
 
 
    'Définit la plage de cellules pour la recherche de doublons
    Set Plage = Worksheets("Feuil1").Range("A1:A10")
 
    On Error Resume Next
    'Boucle sur les cellules de la plage cible
    For Each Cell In Plage
        'Création d'une collection de données uniques (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(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
 
    'On sort si aucun doublon n'a été trouvé.
    If x = 0 Then Exit Sub
 
    'Fige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = False
 
    'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
    For x = UBound(Tableau) To LBound(Tableau) Step -1
        Worksheets("Feuil1").Rows(Tableau(x)).EntireRow.Delete
    Next x
 
    Application.ScreenUpdating = True
End Sub

Sub DeleteDouble()
  Dim rRange As Range
  Dim rCell As Range
 
  Set rRange = Range([A1], [A1].End(xlDown))
 
  For Each rCell In rRange
    Do While rCell = rCell.Offset(1, 0)
      rCell.Offset(1, 0).EntireRow.Delete
    Loop
  Next rCell
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

Sub DAOdedoublonnage()
'lancer le processus de dédoublonnage
Dim rT As Range, rD As Range, rCible As Range
Dim sql As String, group As String
 
On Error GoTo sortiePropre
 
Set rT = application.InputBox("Sélection de la table sans les libellés", _
                    "Dédoublonnage", Selection.AddressLocal, Type:=8)
 
Set rD = application.InputBox("Sélection du/des champs critère(s)", _
                    "Dédoublonnage", Selection.AddressLocal, Type:=8)
 
Set rCible = application.InputBox("Indication de la plage de restitution", _
                    "Dédoublonnage", Selection.AddressLocal, Type:=8)
 
Dim db As DAO.database
Dim rs As DAO.Recordset
 
Set db = DAO.OpenDatabase(rT.Parent.Parent.FullName, False, False, "Excel 8.0;HDR=NO;")
 
For i = 0 To rT.Columns.Count - 1
    If Intersect(rD, rT.Parent.Cells(rT.Row, rT.Column + i)) Is Nothing Then
        sql = sql & ", First([F" & i + 1 & "])"
    Else
        sql = sql & ", [F" & i + 1 & "]"
        group = group & ", [F" & i + 1 & "]"
    End If
Next i
sql = "SELECT " & Mid(sql, 3) & " " & _
        "FROM [" & rT.Parent.Name & "$" & rT.Address(False, False, xlA1) & "] " & _
        "GROUP BY " & Mid(group, 3)
'Debug.Print sql
Set rs = db.OpenRecordset(sql, DAO.dbOpenSnapshot)
rCible.CopyFromRecordset rs
rs.Close
 
sortiePropre:
Set rD = Nothing
Set rT = Nothing
Set rCible = Nothing
Set db = Nothing
Set rs = Nothing
 
End Sub

=SI(A2="";"";SI(NB.SI(B$2:B20;A2)>0;"";MAX($D$1:$D1)+1))

=SI(LIGNES($C$2:$C2)>MAX($C$2:$C$20);"";DECALER($A$2;EQUIV(LIGNES($C$2:$C2);$C$2:$C$20;0)-1;0))