Sub Compter()
Dim Couleurs, MonDico, C, mRange, Last
Dim Plg
Dim Maxi, iMaxi
Set ws1 = Sheets("feuil1")
Set MonDico = CreateObject("Scripting.Dictionary")
[E:F].ClearContents
Last = [A65000].End(xlUp).Row
Set mRange = Range("C2:C" & Last): mRange.Interior.ColorIndex = Null
For Each C In mRange
If C <> "" Then MonDico.Item(C.Value) = MonDico.Item(C.Value) + 1
Maxi = IIf(Maxi > MonDico.Item(C.Value), Maxi, MonDico.Item(C.Value))
iMaxi = IIf(Maxi > MonDico.Item(C.Value), iMaxi, C)
Next C
[E2].Resize(MonDico.Count) = Application.Transpose(MonDico.Keys)
[F2].Resize(MonDico.Count) = Application.Transpose(MonDico.items)
Last = [F65000].End(xlUp).Row
Set Plg = ws1.Range("E2:E" & Last)
DMax = Application.Max(MonDico.items)
Cells(Last + 2, "F").Value = DMax
Cells(Last + 2, "E").Value = iMaxi
End Sub