Sub test()
    Dim dic As Object, i&, txt$, ikey, arr, lkey
    
    Set dic = CreateObject("Scripting.Dictionary")
    i = 1
    Do Until Range("a" & i).Value = Empty
        txt = Range("a" & i).Value
        dic.Item(txt) = dic.Item(txt) & i & "|"
        i = i + 1
    Loop
    For Each ikey In dic.keys
        txt = CStr(Left(dic.Item(ikey), Len(dic.Item(ikey)) - 1))
        If InStr(1, txt, "|", vbTextCompare) <> 0 Then
            arr = Split(dic.Item(ikey), "|")
            For Each lkey In arr
                If lkey <> "" Then Range("a" & Val(lkey)).Interior.Color = vbRed
            Next lkey
        End If
    Next ikey
End Sub

Dic.Item(cstr(cells(i,j))) = Dic.Item(cstr(cells(i,j))) +1

Dic.Item(cstr(cells(i,j))) >1

Option Explicit

Sub select_replica() 'рабочий
Dim arr, x, R As Range, 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")
If Selection.CountLarge = 1 Then Set R = ActiveSheet.UsedRange Else Set R = Intersect(ActiveSheet.UsedRange, Selection)
If R Is Nothing Then Exit Sub

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

For A = 1 To R.Areas.Count
    iEnd = R.Areas(A).Count / R.Areas(A).Columns.Count
    jEnd = R.Areas(A).Count / R.Areas(A).Rows.Count
    y = 0
    For i = 1 To iEnd
        For j = 1 To jEnd
        If iEnd + jEnd = 2 Then x = R.Areas(A).Item(1).Value Else x = arr(A)(i, j)
        y = y + 1
            If Not IsEmpty(x) And x <> "" Then If Not dict.Exists(x) Then dict.Add x, R.Areas(A).Item(y) Else Union(R.Areas(A).Item(y), dict.Item(x)).Interior.Color = 6740479
        Next
    Next
Next
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
End Sub