Bonjour,
En partant du code de Mytå :
Sub NbDoublons()
Dim Cel As Range, Plg As Range
Dim MonDico As Object, MonDico2 As Object
Set MonDico = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
With Sheets("saisie")
Set Plg = .Range("A5:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
For Each Cel In Plg
If Not MonDico.Exists(Cel.Value) Then
MonDico(Cel.Value) = Cel.Value
Else
MonDico2(Cel.Value) = Application.CountIf(Plg, Cel.Value)
End If
Next Cel
End With
With Sheets("extraction")
.Columns("A:B").ClearContents
.[A5].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.Keys)
.[B5].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.Items)
.Range("A5:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=.Range("B5"), Order1:=xlDescending, Header:=xlNo
End With
End Sub
Bonne journée