Sub SupDoublons2()
Application.ScreenUpdating = False
Set f1 = Sheets("BD")
a = f1.Range("A1").CurrentRegion.Value
Dim c()
ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
ligne = 1
Set mondico = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a)
If Not mondico.exists(a(i, 1)) Then
mondico.Add a(i, 1), 1
For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
ligne = ligne + 1
End If
Next
Sheets("resultat").[A1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub