Option Explicit

Sub CountColours()
'считает количество цветов заливки в выделенном диапазоне
Dim Rng As Range, iCell As Range
Dim iLastRow, TotalSum As Long
Dim UsedColours As New Collection, i As Long
    
    'различные проверки
    If TypeName(Selection) <> "Range" Then
        MsgBox "Выделите ячейки на листе Excel!", 48, "Ошибка"
        Exit Sub
    End If
    Set Rng = Selection.Cells
    If Rng.Columns.Count > 1 Then
        MsgBox "Выделите диапазон ячеек в одном столбце!", 48, "Ошибка"
        Exit Sub
    End If
    If Rng.Cells.Count = 1 Then
        MsgBox "Выделите диапазон ячеек!", 48, "Ошибка"
        Exit Sub
    End If
    If Application.CountA(Rng) = 0 Then
        MsgBox "Выделенный диапазон пуст!", 48, "Ошибка"
        Exit Sub
    End If
    
    'заполняем коллекцию номерами цветов без задвоений. Ячейка без цвета -4142
    On Error Resume Next
    For Each iCell In Rng
        UsedColours.Add iCell.Interior.ColorIndex, CStr(iCell.Interior.ColorIndex)
    Next iCell
    On Error GoTo 0
    
    'результаты будем проставлять ниже на 2 ячейки
    iLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row + 3
    'считаем количество каждого цвета в выделенном диапазоне и проставляем в нужную ячейку
    For i = 1 To UsedColours.Count
        Cells(iLastRow, ActiveCell.Column).Interior.ColorIndex = UsedColours(i)
        For Each iCell In Rng
            If iCell.Interior.ColorIndex = UsedColours(i) Then TotalSum = TotalSum + 1
        Next iCell
        Cells(iLastRow, ActiveCell.Column) = TotalSum
        TotalSum = 0
        iLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row + 1
    Next i
    MsgBox "Цвета посчитаны", 64, "Конец"
End Sub