[RESOLU] Classement doublons

=INDEX(B:B;EQUIV(MAX(NB.SI(B$1:B$1000;B$1:B$1000));NB.SI(B$1:B$1000;B$1:B$1000);0))

=SIERREUR(PETITE.VALEUR(SI((NB.SI(B$1:B$1000;B$1:B$1000)>1)*(NB.SI(C$3:C3;B$1:B$1000)=0);B$1:B$1000);1);"")

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address <> "$C$3" Then Exit Sub 'adresse à adapter
Dim t, t1(), d As Object, i&, j&
Cancel = True
t = Range("B1", Range("B" & Rows.Count).End(xlUp)(2)) 'matrice, plus rapide
ReDim t1(1 To UBound(t), 1 To 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If t(i, 1) <> "" Then
    If d.exists(t(i, 1)) Then
      j = d(t(i, 1))
      If t1(j, 1) = "" Then t1(j, 1) = t(i, 1)
      t1(j, 2) = t1(j, 2) + 1
    Else
      d(t(i, 1)) = i
    End If
  End If
Next
'---restitution---
Application.ScreenUpdating = False
Target.Resize(Rows.Count - Target.Row + 1).ClearContents 'RAZ
Target(1, 2).EntireColumn.Insert 'colonne auxiliaire
With Target.Resize(UBound(t), 2)
  .Value = t1
  '---classement pour trouver les maxima---
  .Sort Target(1, 2), xlDescending, , Target, xlAscending, Header:=xlNo
  For i = 2 To UBound(t)
    If .Cells(i, 2) <> .Cells(1, 2) Then
      ThisWorkbook.Names.Add "lig", i + Target.Row - 1 'nom défini pour la MFC
      Exit For
    End If
  Next
  '---classement du reste---
  .Offset(i - 1).Sort Target, xlAscending, Header:=xlNo
End With
Target(1, 2).EntireColumn.Delete
End Sub