Парная подсветка дубликатов

 Sub DuplicatesColoring1()
  Set objDictDupes = CreateObject("Scripting.Dictionary" )
  Selection.Interior.ColorIndex = -4142
  i = 3
  For Each cell In Selection
    If objDictDupes.Exists(cell.Value) Then
   If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
     cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
   Else
     objDictDupes.Item(cell.Value).Interior.ColorIndex = i
     cell.Interior.ColorIndex = i
     i = i + 1
   End If
    Else
   objDictDupes.Add cell.Value, cell
    End If
  Next
End Sub

Sub Выделить_несколько_строк3()
    Dim w1 As Range
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    wb.Sheets(4).Activate
    myword = InputBox("Введите искомое слово:")
    For Each w1 In ActiveSheet.UsedRange.Cells
        If w1 <> Empty Then
            If w1 = Cells.Find(myword) Then
                w1.Select
                Selection.Interior.Color = RGB(255, 0, 0)
            End If
        End If
    Next w1
End Sub

Sub Выделить_несколько_строк3()
    Dim w1, nach As Range
    Dim redCLR, grCLR, blCLR As Byte
    Dim myword As String
    redCLR = 231    ' устанавливает счетчик красного для цвета
    grCLR = 231    ' устанавливает счетчик зеленого для цвета
    blCLR = 231    ' устанавливает счетчик синего для цвета
    Sheets(4).Activate
    Do    ' запуск цикла
        myword = InputBox("Введите искомое слово:")    ' ввод слова
        If myword = "" Then Exit Sub    ' проверка на пустоту, если да - выход из цикла
        Set nach = Cells.Find(myword)    ' устанавливает первую позицию слова
        If Not nach Is Nothing Then Set w1 = Cells.FindNext(nach) Else Exit Sub    ' если слово найдено, ищет следующую позицию, если нет, завершение алгоритма
        Do    ' запуск нового цикла
            w1.Interior.Color = RGB(redCLR, grCLR, blCLR)    ' раскраска второй найденной ячейки
            If redCLR > 0 Then    ' смена цвета
                redCLR = redCLR - 33
            Else
                redCLR = 231
                If grCLR > 0 Then
                    grCLR = grCLR - 33
                Else
                    grCLR = 231
                    If blCLR > 0 Then
                        blCLR = blCLR - 33
                    Else
                        blCLR = 231
                    End If
                End If
            End If
            Set w1 = Cells.FindNext(w1)    ' поиск следующей ячейки
        Loop While nach.Address <> w1.Address    ' повтор цикла, если адрес 1ой найденной ячейки и следующей не совпадает
    Loop While myword <> ""    ' повтор цикла, если слово не пустое
End Sub

Public Function GetR(cell As Range) As Double
    GetR = cell.Interior.Color
End Function

Range("A1").Interior.Color = RGB(255,127,0)