Sub CompteCouleurs()
Dim r As Range
Application.ScreenUpdating = False
[AA3].Resize(Rows.Count - 2, Columns.Count - 26).Clear 'RAZ
For Each r In Range("AA1", Cells(1, Columns.Count).End(xlToLeft))
If r <> "" Then Restitution Range(r), r.Column
Next
Application.Goto [AA1], True 'cadrage
End Sub
Sub Restitution(r As Range, col%)
Dim d As Object, a, b, i&
Set d = CreateObject("Scripting.Dictionary")
For Each r In r
If r.Interior.ColorIndex <> xlNone Then _
d(r.Interior.Color) = d(r.Interior.Color) + 1
Next
'---restitution---
If d.Count Then
a = d.keys: b = d.items
For i = 0 To UBound(a)
Cells(i + 3, col).Interior.Color = a(i)
Cells(i + 3, col + 1) = b(i)
Next
'---formatage et tri---
Columns(col + 1).HorizontalAlignment = xlCenter
Cells(2, col).Resize(Rows.Count - 1, 2).Sort Columns(col + 1), xlDescending
End If
End Sub