Sub Закрасить_повторы()

    Dim arrSrc(), arrPovt() As Boolean
    Dim lr As Long, i As Long, ii As Long
    
    Application.ScreenUpdating = False
    
    lr = Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrSrc() = Range("A1:A" & lr).Value
    ReDim arrPovt(1 To UBound(arrSrc), 1 To 1)
    
    For i = 1 To UBound(arrSrc)
        arrSrc(i, 1) = LCase(arrSrc(i, 1))
    Next
    
    For i = 1 To UBound(arrSrc) - 1
        If arrPovt(i, 1) = False Then
            For ii = i + 1 To UBound(arrSrc)
                If arrSrc(i, 1) = arrSrc(ii, 1) Then
                    arrPovt(i, 1) = True
                    arrPovt(ii, 1) = True
                End If
            Next
        End If
    Next
    
    For i = 1 To UBound(arrPovt)
        If arrPovt(i, 1) = True Then
            Cells(i, "A").Interior.Color = 11389944
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation

End Sub

Sub select_replica3()
Dim arr, i As Long, j As Long, ColN As Long
ColN = 3 'задаем номер столбца
With Application: .ScreenUpdating = False: .StatusBar = "Обработка данных...": End With
With ActiveSheet.UsedRange.Resize(, 1).Offset(, ColN - ActiveSheet.UsedRange.Column)
.Columns.Interior.Pattern = xlNone: arr = .Columns.Value
     For i = 1 To .Rows.count
        For j = i + 1 To .Rows.count
            If IsEmpty(arr(i, 1)) Then Exit For Else If Not IsEmpty(arr(j, 1)) Then If arr(j, 1) = arr(i, 1) Then Union(.Rows(j), .Rows(i)).Interior.Color = 39423: Exit For
        Next
     Next
End With
With Application: .ScreenUpdating = True: .StatusBar = False: End With
End Sub

Option Explicit
'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 5 от 25/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim arr, x, Rn As Range, s(1) As Long, A As Long, i As Long, j As Long, iEnd As Long, jEnd As Long, Y As Long, ac, t
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
t = Timer
If Selection.CountLarge = 1 Then Set Rn = ActiveSheet.UsedRange Else Set Rn = Intersect(ActiveSheet.UsedRange, Selection)
If Rn Is Nothing Then Exit Sub

With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Rn.Interior.Pattern = Empty
 
ReDim arr(1 To Rn.Areas.Count)
For A = 1 To Rn.Areas.Count
    arr(A) = Rn.Areas(A).Value
Next

For A = 1 To Rn.Areas.Count
    iEnd = Rn.Areas(A).Count / Rn.Areas(A).Columns.Count
    jEnd = Rn.Areas(A).Count / Rn.Areas(A).Rows.Count
    Y = 0
    For i = 1 To iEnd
        For j = 1 To jEnd
        If iEnd + jEnd = 2 Then x = Rn.Areas(A).Item(1).Value Else x = arr(A)(i, j)
        Y = Y + 1
            If Not IsEmpty(x) Then
                If Not Dict.Exists(x) Then
                    s(0) = Y
                    If Y = 1 Then s(1) = 6740479 Else s(1) = Generate_nice_color
                    Dict.Add x, s
                Else
                    Union(Rn.Areas(A).Item(Y), Rn.Areas(A).Item(Dict.Item(x)(0))).Interior.Color = Dict.Item(x)(1)
                End If
            End If
        Next
    Next
Next
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "= " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & Dict.Count, vbInformation
End Sub

Function Generate_nice_color() As Long
Dim R, G, B
Do
    Randomize
    R = Int(Rnd * 256)
    G = Int(Rnd * 256)
    B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function

Option Explicit
'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 6 от 26/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim R As Range, Rf As Range, Rc As Range, i As Long, s(3) As Long, ac, t, x, cell
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
Dim DictColor: Set DictColor = CreateObject("Scripting.Dictionary")
t = Timer

On Error Resume Next
If Selection.CountLarge = 1 Then
    Set Rf = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Else
    Set Rf = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, 23)
End If
On Error GoTo 0

With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Set R = Rf: GoSub Go_
Set R = Rc: GoSub Go_
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "select_replica = " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & i, vbInformation
Exit Sub
    
Go_:
If Not R Is Nothing Then
    R.Interior.Pattern = Empty
    For Each cell In R.Cells
        If Dict.Exists(cell.Value) Then
            x = Dict.Item(cell.Value)
            If x(3) = 1 Then
                i = i + 1
                If i = 1 Then
                    x(2) = 6740479 ' мой первый :)
                Else
                    Do 'гарантия уникального цвета на группу дубликатов - жрёт 12%
                        x(2) = Generate_nice_color
                    Loop While DictColor.Exists(x(2))
                    DictColor.Add cell.Value, 0
                End If
                x(3) = 2
                Dict.Item(cell.Value) = x
                Cells(x(0), x(1)).Interior.Color = x(2)
            End If
            cell.Interior.Color = x(2)
        Else
            s(0) = cell.Row
            s(1) = cell.Column
            s(3) = 1
            Dict.Add cell.Value, s
        End If
    Next
End If
Return
End Sub

Function Generate_nice_color() As Long
Dim R As Long, G As Long, B As Long
Do
    Randomize
    R = Int(Rnd * 256)
    G = Int(Rnd * 256)
    B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function

If i = 1 Then
                    x(2) = 6740479 ' мой первый :)
                Else
                    Do 'гарантия уникального цвета на группу дубликатов - жрёт 12%
                        x(2) = Generate_nice_color
                    Loop While DictColor.Exists(x(2))
                    DictColor.Add cell.Value, 0
                End If

x(2) = 6740479