Option Explicit
'===========================================================================================
Sub DuplicatesColors()
Dim dicAll As New Dictionary, dicDupl As New Dictionary
Dim x, arr, arrColors(), arrWordIgnore(), arrAll() As String, rng As Range, txt$, r&, clr&, fr&, fc As Byte, rsz As Byte
Const ofsLeft As Byte = 0, ofsRight As Byte = 4 ' сколько красить влево от выделенного столбца и вправо
 
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If rng Is Nothing Then Exit Sub
If rng.Cells.Count = 1 Then Exit Sub                        ' более 1 ячейки
If rng.Areas.Count <> 1 Then Exit Sub                       ' не более одной области
If rng.Columns.Count <> 1 Then Exit Sub                     ' не более 1 столбца
 
arrColors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, 9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)  ' массив цветов для раскраски
arrWordIgnore = Array("ИТОГО", "ИТОГ", "ВСЕГО") ' список слов, которые будут игнорироваться при проверке на дубликат
arr = rng.Value2: ReDim arrAll(UBound(arr, 1) - 1): clr = -1

    For r = 1 To UBound(arr, 1)

        txt = UCase$(arr(r, 1))
        For Each x In arrWordIgnore
            txt = Replace$(Replace$(txt, x & ":", ""), x, "")
        Next x

        txt = WorksheetFunction.Clean((Trim(txt)))
        arrAll(r - 1) = txt

        If Len(txt) And Not dicDupl.Exists(txt) Then
            If dicAll.Exists(txt) Then
                clr = clr + 1: If clr > UBound(arrColors) Then clr = 0
                dicDupl(txt) = arrColors(clr)
            Else
                x = dicAll(txt)
            End If
        End If

    Next r
dicAll.RemoveAll: If dicDupl.Count = 0 Then MsgBox "Дубликаты не найдены…", vbInformation, "НЕТ РАБОТЫ": Exit Sub
fr = rng(1).Row: fc = rng(1).Column - ofsLeft
If fc < 1 Then MsgBox "Смещение ВЛЕВО выбрано некорректно!", vbCritical, "ОШИБКА ДИАПАЗОНА": Exit Sub
rsz = ofsLeft + ofsRight + 1
 
Application.ScreenUpdating = False
rng.Interior.Color = xlNone
 
    For r = 0 To UBound(arrAll)
        If dicDupl.Exists(arrAll(r)) Then Cells(fr + r, fc).Resize(1, rsz).Interior.Color = dicDupl(arrAll(r))
    Next r
 
Application.ScreenUpdating = True
End Sub