compter sans doublon

Sub Doublon()
Dim Doublons As Object
Dim Cel As Range, Plage As Range
Dim I As Integer
Dim Temp
Set Doublons = CreateObject("Scripting.Dictionary")
Set Plage = Range("B16:B30")
For Each Cel In Plage
    If Cel <> "" Then Doublons.Item(Cel.Value) = Cel.Value
Next Cel
Temp = Application.Transpose(Doublons.items)
For I = LBound(Temp) To UBound(Temp)
    y = y & Temp(I, 1) & " * " & Application.CountIf(Plage, Temp(I, 1)) & Chr(13)
Next I
MsgBox y
End Sub

Sub Essai5()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In mondico.keys
    temp = temp & c & "*" & mondico.Item(c) & vbLf
  Next c
  MsgBox temp
End Sub


Sub Essai4()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
     mondico.Item(c.Value) = c.Value & " *  " & Val(Right(mondico(c.Value), 3)) + 1
  Next c
  [j2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Sub Essai1()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  [E2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [F2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Sub Essai2()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  a = mondico.keys
  b = mondico.items
  For i = LBound(a) To UBound(a)
    Cells(i + 2, 8) = a(i) & "*" & b(i)
  Next i
End Sub

Sub Essai3()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  i = 2
  For Each c In mondico.keys
    Cells(i, 9) = c & "*" & mondico.Item(c)
    i = i + 1
  Next c
End Sub