Sub CompteCouleurs()
Dim d As Object, c As Range, a, b, i&
Set d = CreateObject("Scripting.Dictionary")
For Each c In ActiveSheet.[C2:S31]
If c.Interior.ColorIndex <> xlNone Then _
d(c.Interior.Color) = d(c.Interior.Color) + 1
Next
'---restitution---
If d.Count Then
Application.ScreenUpdating = False
a = d.keys: b = d.items
With Workbooks.Add.Sheets(1) 'nouveau document
For i = 0 To UBound(a)
.Cells(i + 2, 1).Interior.Color = a(i)
.Cells(i + 2, 2) = b(i)
Next
'---formatage---
.[A1] = "Couleur": .[B1] = "Nombre"
.[A1:B1].Font.Bold = True
.[B:B].HorizontalAlignment = xlCenter
.[A:B].Sort .[B1], xlDescending, Header:=xlYes 'tri
End With
End If
End Sub