Sub подсветить_дубликаты()
Dim dict As Object, arr As Variant, exception_arr As Variant, exception_dict As Object, item As Variant
Dim i As Variant, data_range As Range

exception_arr = Array("картошка", "огурцы") ' в этот массив ИСКЛЮЧЕНИЙ (регистр и порядок не имеет значения)
Set exception_dict = CreateObject("Scripting.Dictionary") ' создаем словарь исключений
' загружаем исключения в словарь исключений
For i = LBound(exception_arr) To UBound(exception_arr)
    exception_dict.Add LCase(Trim(exception_arr(i))), 0 ' загоняем слова из масиива исключений в словарь exception_dict
Next i

Set data_range = Application.InputBox("выберите диапазон для выделения дубликатов", , , , , , , 8) ' выбор диапазона (тип 8 == объекту диапазон)
arr = data_range ' загоняем выделенный диапазон в массив
Set dict = CreateObject("Scripting.Dictionary") ' создаем словарь

' ниже цикл для поиска дубликатов в выделенном дипазоне (уже помещенном в массив)
For i = LBound(arr, 1) To UBound(arr, 1)
    If Not dict.exists(arr(i, 1)) Then ' если нет такого в словаре, то
        dict.Add (LCase(Trim(arr(i, 1)))), 1 ' ключ словаря == значение, значение словаря == 1 (т.е количество повторов)
    Else ' иначе
        dict(arr(i, 1)) = dict(arr(i, 1)) + 1 ' прибавляем 1 к значению словаря ( то есть этот участовк кода отрабатывает, когда найден первый и последующий дубликаты)
    End If
Next i
'---------------------------------------------------------------------------
' ОБРАБАТЫВАЕМ ИСКЛЮЧЕНИЯ
For Each item In dict.keys() ' цикл по ключам словаря для удаления исключений
    If exception_dict.exists(item) Then dict(item) = 0 ' если значение item присутствует в словаре исключений exception_dict, то сбрасываем счетчик количества этого значения _
    в словаре dict с ключем item
Next item
'---------------------------------------------------------------------------
'ОКРАСКА ЯЧЕЕК
For i = LBound(arr, 1) To UBound(arr, 1) ' цикл по массиву
    If dict(arr(i, 1)) > 1 Then data_range(i, 1).Interior.Color = RGB(255, 242, 204)  ' если есть дубликаты, то красим
Next i
'----------------------------------------------------------------------------
End Sub
Sub очистка_формата()
' очистка форматов для выделенного участка листа
With Selection
    .ClearFormats
End With
End Sub 

Sub подсветить_дубликаты()
Dim dict As Object, arr As Variant, exception_arr As Variant, item As Variant
Dim i As Variant, data_range As Range

exception_arr = Array("картошка", "огурцы") ' в этот массив ИСКЛЮЧЕНИЙ заносим значения в алфавитном порядке, так как для поиску по нему используется БИНАРНЫЙ ПОИСК

Set data_range = Application.InputBox("выберите диапазон для выделения дубликатов", , , , , , , 8) ' выбор диапазона (тип 8 == объекту диапазон)
arr = data_range ' загоняем выделенный диапазон в массив
Set dict = CreateObject("Scripting.Dictionary") ' создаем словарь

' ниже цикл для поиска дубликатов в выделенном дипазоне (уже помещенном в массив)
For i = LBound(arr, 1) To UBound(arr, 1)
    If Not dict.exists(arr(i, 1)) Then ' если нет такого в словаре, то
        dict.Add (arr(i, 1)), 1 ' ключ словаря == значение, значение словаря == 1 (т.е количество повторов)
    Else ' иначе
        dict(arr(i, 1)) = dict(arr(i, 1)) + 1 ' прибавляем 1 к значению словаря ( то есть этот участовк кода отрабатывает, когда найден первый и последующий дубликаты)
    End If
Next i

For Each item In dict.keys() ' цикл по ключам словаря для удаления исключений
    If binary_search(exception_arr, item) <> -1 Then dict(item) = 0 ' если значение item присутствует в массиве исключений, то сбрасываем счетчик количества этого значения
Next item

For i = LBound(arr, 1) To UBound(arr, 1) ' цикл по массиву
    If dict(arr(i, 1)) > 1 Then data_range(i, 1).Interior.Color = RGB(255, 242, 204)  ' если есть дубликаты, то красим
Next i
End Sub
Sub очистка_формата()
' очистка форматов для выделенного участка листа
With Selection
    .ClearFormats
End With
End Sub
Private Function binary_search(arr, what) As Long
'функция поиска значения what  в одномерном массиве arr
Dim p, q, r
p = 0: r = UBound(arr)
While p <= r
    q = Int((p + r) / 2)
    If LCase(Trim(arr(q))) = LCase(Trim(what)) Then binary_search = q: Exit Function
    If LCase(Trim(arr(q))) > LCase(Trim(what)) Then
        r = q - 1
    Else
        p = q + 1
    End If
Wend
binary_search = -1
End Function

Sub подсветить_дубликаты()
Dim dict As Object, arr As Variant, exception_arr As Variant
Dim i As Variant, data_range As Range

exception_arr = Array("картошка", "огурцы") ' в этот массив ИСКЛЮЧЕНИЙ заносим значения в алфавитном порядке, так как для поиску по нему используется БИНАРНЫЙ ПОИСК

With ActiveSheet

    Set data_range = Application.InputBox("выберите диапазон для выделения дубликатов", , , , , , , 8) ' выбор диапазона (тип 8 == объекту диапазон)
    arr = data_range ' загоняем выделенный диапазон в массив
    Set dict = CreateObject("Scripting.Dictionary") ' создаем словарь
    
    ' ниже цикл для поиска дубликатов в выделенном дипазоне (уже помещенном в массив)
    For i = LBound(arr, 1) To UBound(arr, 1)
        If binary_search(exception_arr, arr(i, 1)) = -1 Then
            If Not dict.exists(arr(i, 1)) Then ' если нет такого в словаре, то
                dict.Add (arr(i, 1)), 1 ' ключ словаря == значение, значение словаря == 1 (т.е количество повторов)
            Else ' иначе
                dict(arr(i, 1)) = dict(arr(i, 1)) + 1 ' прибавляем 1 к значению словаря ( то есть этот участовк кода отрабатывает, когда найден первый и последующий дубликаты)
            End If
        End If
    Next i
    
    For i = LBound(arr, 1) To UBound(arr, 1) ' цикл по массиву
        If dict(arr(i, 1)) > 1 Then data_range(i, 1).Interior.Color = RGB(255, 242, 204) ' если есть дубликаты, то красим
    Next i
End With
End Sub
Sub очистка_формата()
' очистка форматов для выделенного участка листа
With Selection
    .ClearFormats
End With
End Sub
Private Function binary_search(arr, what) As Long
'функция поиска значения what  в одномерном массиве arr
Dim p, q, r
p = 0: r = UBound(arr)
While p <= r
    q = Int((p + r) / 2)
    If LCase(Trim(arr(q))) = LCase(Trim(what)) Then binary_search = q: Exit Function
    If LCase(Trim(arr(q))) > LCase(Trim(what)) Then
        r = q - 1
    Else
        p = q + 1
    End If
Wend
binary_search = -1
End Function