Option Explicit
'===========================================================================================
Sub MarkDuplicates()
Dim arr(), arrAdr() As String, r&, i&, txtCompare$, tm!
Const mark$ = "жопка"

tm = Timer: arr = Worksheets("все").[a2:c317].Value2: If Not Array2xSort_Text(arr, 2) Then MsgBox "Сортировка не выполнена", vbCritical, "ОШИБКА": Exit Sub
ReDim arrAdr(0 To UBound(arr, 1)): i = -1

    For r = 2 To UBound(arr, 1)
        If arr(r, 2) = arr(r - 1, 2) Then
            If arr(r, 1) <> arr(r - 1, 1) Then i = i + 1: arrAdr(i) = arr(r, 2)
        End If
    Next r

txtCompare = "•" & Join(arrAdr, "•") & "•"

    For r = 1 To UBound(arr, 1)
        If InStr(1, txtCompare, "•" & arr(r, 2) & "•") Then arr(r, 3) = mark
    Next r

Worksheets("все").[e2].Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
MsgBox "Макрос успешно завершён за " & Format$(Timer - tm, "0.00 сек"), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'МОЗГИ: ТЕКСТОВЫЙ сортер 2x-массива от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=98837&TITLE_SEO=98837-sortirovka-v-dvumernom-massive-vba-excel&MID=955983#message955983
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function Array2xSort_Text(arr2xTmp(), Optional ByVal nSort As Byte = 1) As Boolean
Dim bMap(), bb() As Byte, x&, xx&
Dim a&, b&, c&, d&, dt$, cc(), lMax&, dd&(), aa&()

ReDim dd(LBound(arr2xTmp) To UBound(arr2xTmp)): lMax = 3: x = 3
For a = LBound(arr2xTmp) To UBound(arr2xTmp): dd(a) = a: Next a
If LBound(arr2xTmp) = 0 Then d = lMax Else d = 0
dt = Space(lMax * (UBound(arr2xTmp) - LBound(arr2xTmp) + 1)): b = 1

    For a = LBound(arr2xTmp) To UBound(arr2xTmp)
        Mid$(dt, b, lMax) = Mid$(arr2xTmp(dd(a), nSort), 1, lMax): b = b + lMax
    Next a

bb = StrConv(dt, 128): dt = vbNullString

    For b = x To 1 Step -1
        xx = LBound(arr2xTmp): ReDim bMap(32 To 255)
        For a = LBound(dd) To UBound(dd)
            x = dd(a) * lMax - lMax + d + b - 1: bMap(bb(x)) = bMap(bb(x)) + 1
        Next a
        For a = LBound(dd) To UBound(dd)
            x = dd(a) * lMax - lMax + d + b - 1
            If IsArray(bMap(bb(x))) Then
                bMap(bb(x))(0) = bMap(bb(x))(0) + 1: bMap(bb(x))(bMap(bb(x))(0)) = dd(a)
            Else
                ReDim aa(0 To bMap(bb(x)) + 1): aa(0) = 1: aa(1) = dd(a): bMap(bb(x)) = aa
            End If
        Next a
        For a = 32 To 255
            If IsArray(bMap(a)) Then
                For x = 1 To bMap(a)(0): dd(xx) = bMap(a)(x): xx = xx + 1: Next x
            End If
        Next a
    Next b
ReDim aa(LBound(dd) To UBound(dd)): aa(LBound(aa)) = dd(LBound(dd)): Erase bb
    For a = LBound(dd) + 1 To UBound(dd)
        b = a
        Do While StrComp(arr2xTmp(aa(b - 1), nSort), arr2xTmp(dd(a), nSort), 0) = 1
          aa(b) = aa(b - 1): b = b - 1: If b = LBound(aa) Then Exit Do
        Loop
        aa(b) = dd(a)
    Next a
Erase dd: Erase bMap: x = LBound(arr2xTmp, 2): xx = UBound(arr2xTmp, 2)
ReDim cc(LBound(arr2xTmp) To UBound(arr2xTmp), x To xx)
    For a = LBound(aa) To UBound(aa)
        For b = x To xx: cc(a, b) = arr2xTmp(aa(a), b): Next b
    Next a
arr2xTmp = cc: Erase aa: Erase cc: Array2xSort_Text = True
End Function