Sub ENLEVER_DOUBLONS()
ListeValUniques Range("A2:A5000"), Range("E1")
End Sub
Sub ListeValUniques(PlageSrc As Range, CellDest As Range)
'Extrait les valeurs uniques d'une colonne et les renvoie
'dans une autre, à partir de CellDest
Dim Arr1, Elt, Arr2(), Coll As New Collection
If PlageSrc.Columns.Count > 1 Then Exit Sub
Arr1 = PlageSrc.Value
For Each Elt In Arr1
On Error Resume Next
Coll.Add Elt, CStr(Elt)
If Err.Number = 0 Then
ReDim Preserve Arr2(1 To Coll.Count)
Arr2(Coll.Count) = Elt
End If
On Error GoTo 0
Next
CellDest.Resize(Coll.Count).Value = _
Application.Transpose(Arr2)
End Sub