Option Explicit
Const mark$ = "жопка"
'===========================================================================================
Sub Test() 'ORIGINAL = 98 107 marks | COPY = 45 558 marks
Dim sh As Worksheet, arr(), tm!, t!
tm = Timer: Application.ScreenUpdating = False: Set sh = shCopy ' выбираем источник

' BEGIN
t = Timer
shStart.Range("A2:C1001000").ClearContents
arr = sh.Range("A1:C" & sh.Cells(Rows.Count, 2).End(xlUp).Row).Value2
shStart.Range("A2:C" & UBound(arr, 1) + 1).Value2 = arr
Debug.Print "Begin: " & Format$(Timer - t, "0.00 сек")
Debug.Print String(50, "-")

t = Timer
'Call PRDX_SortDic(arr)
'Call PRDX_SortDicAnch(arr)
'Call PRDX_NoSort(arr)
Call Nordheim(arr)
Debug.Print "MAIN: " & Format$(Timer - t, "0.00 сек")

' END
t = Timer
shStart.Cells(2, 1).Resize(UBound(arr, 1), 3).Value2 = arr
Debug.Print String(50, "-")
Debug.Print "End: " & Format$(Timer - t, "0.00 сек")

Debug.Print "Время работы макроса: " & Format$(Timer - tm, "0.00 сек")
fin: Application.ScreenUpdating = True
End Sub
'===========================================================================================
Private Sub PRDX_SortDic(arr())
Dim x, dic As Object, r&, n&, t!

t = Timer
shStart.Range("A2:C" & UBound(arr, 1) + 1).Sort Key1:=shStart.Cells(2, 2), Order1:=xlAscending, Key2:=shStart.Cells(2, 1), Order2:=xlAscending, Header:=xlNo, MatchCase:=True
Debug.Print "Range Sort: " & Format$(Timer - t, "0.00 сек")

t = Timer
arr = shStart.Range("A2:C" & UBound(arr, 1) + 1).Value2: Set dic = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arr) - 1
        If arr(r, 2) = arr(r + 1, 2) Then
            If arr(r, 1) <> arr(r + 1, 1) Then x = dic.Item(arr(r, 2)): r = r + 1
        End If
    Next r
Debug.Print "1st cycle: " & Format$(Timer - t, "0.00 сек")

t = Timer
    For r = 1 To UBound(arr, 1)
        If dic.Exists(arr(r, 2)) Then arr(r, 3) = mark
    Next r
Debug.Print "2nd cycle: " & Format$(Timer - t, "0.00 сек")
End Sub
'...........................................................................................
'ORIGINAL =========================================
'Begin: 6,71 сек
'--------------------------------------------------
'Range Sort: 2,17 сек
'1st cycle: 0,54 сек
'2nd cycle: 0,68 сек
'MAIN: 3,40 сек
'--------------------------------------------------
'End: 6,58 сек
'Время работы макроса: 16,70 сек

'COPY =============================================
'Begin: 6,47 сек
'--------------------------------------------------
'Range Sort: 4,07 сек
'1st cycle: 0,48 сек
'2nd cycle: 0,43 сек
'MAIN: 4,98 сек
'--------------------------------------------------
'End: 6,41 сек
'Время работы макроса: 17,87 сек
'===========================================================================================
Private Sub PRDX_SortDicAnch(arr())
Dim x, dic As Object, r&, n&, t!

t = Timer
arr = FILE_Array2xSort(arr, 2)
Debug.Print "Array Sort: " & Format$(Timer - t, "0.00 сек")

t = Timer
Set dic = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arr) - 1
        If arr(r, 2) = arr(r + 1, 2) Then
            If arr(r, 1) <> arr(r + 1, 1) Then x = dic.Item(arr(r, 2)): r = r + 1
        End If
    Next r
Debug.Print "1st cycle: " & Format$(Timer - t, "0.00 сек")

t = Timer
    For r = 1 To UBound(arr, 1)
        If dic.Exists(arr(r, 2)) Then arr(r, 3) = mark
    Next r
Debug.Print "2nd cycle: " & Format$(Timer - t, "0.00 сек")
End Sub
'...........................................................................................
'ORIGINAL =========================================
'Begin: 6,70 сек
'--------------------------------------------------
'Array Sort: 3,28 сек
'1st cycle: 0,14 сек
'2nd cycle: 0,72 сек
'MAIN: 4,14 сек
'--------------------------------------------------
'End: 6,82 сек
'Время работы макроса: 17,66 сек

'COPY =============================================
'Begin: 6,52 сек
'--------------------------------------------------
'Array Sort: 4,14 сек
'1st cycle: 0,12 сек
'2nd cycle: 0,43 сек
'MAIN: 4,69 сек
'--------------------------------------------------
'End: 6,39 сек
'Время работы макроса: 17,60 сек
'===========================================================================================
Private Sub PRDX_NoSort(arr())
Dim x, dic1 As Object, dic2 As Object, r&, t!
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")

t = Timer
    For r = 1 To UBound(arr, 1)
        If dic1.Exists(arr(r, 2)) Then
            If dic1.Item(arr(r, 2)) <> arr(r, 1) Then x = dic2.Item(arr(r, 2))
        Else
            dic1.Item(arr(r, 2)) = arr(r, 1)
        End If
    Next r
dic1.RemoveAll
Debug.Print "1st cycle: " & Format$(Timer - t, "0.00 сек")

t = Timer
    For r = 1 To UBound(arr, 1)
        If dic2.Exists(arr(r, 2)) Then arr(r, 3) = mark
    Next r
Debug.Print "2nd cycle: " & Format$(Timer - t, "0.00 сек")
End Sub
'...........................................................................................
'ORIGINAL =========================================
'Begin: 6,69 сек
'--------------------------------------------------
'1st cycle: 2,95 сек
'2nd cycle: 0,66 сек
'MAIN: 3,62 сек
'--------------------------------------------------
'End: 6,71 сек
'Время работы макроса: 17,02 сек

'COPY ============================================
'Begin: 6,55 сек
'--------------------------------------------------
'1st cycle: 1,02 сек
'2nd cycle: 0,43 сек
'MAIN: 1,45 сек
'--------------------------------------------------
'End: 6,30 сек
'Время работы макроса: 14,30 сек
'===========================================================================================
Private Sub Nordheim(arr())
    Dim objDic As Object
    Dim objd As Object
    Dim i&, j&, t!, txt$
    Set objDic = CreateObject("scripting.dictionary")
    Set objd = CreateObject("scripting.dictionary")
t = Timer
        For i = 1 To UBound(arr)
            txt = arr(i, 2)
            If objDic.Exists(txt) Then
                If objDic.Item(txt) <> arr(i, 1) Then objd.Item(txt) = 0
            Else: objDic.Item(txt) = arr(i, 1)
            End If
        Next
Debug.Print "1st cycle: " & Format$(Timer - t, "0.00 сек")

t = Timer
        For i = 1 To UBound(arr)
            txt = arr(i, 2)
            If objd.Exists(txt) Then arr(i, 3) = mark
        Next
Debug.Print "2nd cycle: " & Format$(Timer - t, "0.00 сек")
End Sub
'...........................................................................................
'ORIGINAL =========================================
'Begin: 6,63 сек
'--------------------------------------------------
'1st cycle: 3,06 сек
'2nd cycle: 0,77 сек
'MAIN: 3,86 сек
'--------------------------------------------------
'End: 6,71 сек
'Время работы макроса: 17,20 сек

'COPY ============================================
'Begin: 6,53 сек
'--------------------------------------------------
'1st cycle: 1,05 сек
'2nd cycle: 0,46 сек
'MAIN: 1,51 сек
'--------------------------------------------------
'End: 6,79 сек
'Время работы макроса: 14,82 сек
'===========================================================================================
'===========================================================================================
'===========================================================================================
Public Function FILE_Array1xSortInd(arrVal(), arrInd() As Long, l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arrVal((l + u) \ 2)
        Do
            Do While arrVal(i) < x: i = i + 1: Loop
            Do While x < arrVal(j): j = j - 1: Loop
            If i <= j Then
                y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
                y = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = y
                i = i + 1: j = j - 1
            End If
        Loop Until i > j
If l < j Then Call FILE_Array1xSortInd(arrVal, arrInd, l, j)
If i < u Then Call FILE_Array1xSortInd(arrVal, arrInd, i, u)
End Function
'-------------------------------------------------------------------------------------------
Public Function FILE_Array2xSort(ByVal arr2x, Optional nCol& = 1) As Variant()
Dim x, arrVal(), arrInd() As Long, r&, c&

x = FILE_Array2xGet1xFromCol(arr2x, nCol, True): arrVal = x(0): arrInd = x(1): Erase x
Call FILE_Array1xSortInd(arrVal, arrInd, 0, UBound(arrInd)): Erase arrVal
ReDim arrNew(1 To UBound(arr2x, 1), 1 To UBound(arr2x, 2))

    For c = 1 To UBound(arr2x, 2): r = 0
        For Each x In arrInd
            r = r + 1: arrNew(r, c) = arr2x(x + 1, c)
        Next x
    Next c

Erase arr2x: FILE_Array2xSort = arrNew
End Function
'-------------------------------------------------------------------------------------------
Public Function FILE_Array2xGet1xFromCol(ByVal arr2x, Optional nCol& = 1, Optional WithIndexes As Boolean) As Variant()
Dim x, arrVal(), r&, i&
ReDim arrVal(0 To UBound(arr2x, 1) - 1)
    If WithIndexes Then
        ReDim arrInd(0 To UBound(arrVal)) As Long: ReDim x(0 To 1)
        For r = 1 To UBound(arr2x, 1)
            i = r - 1: arrVal(i) = arr2x(r, nCol): arrInd(i) = i
        Next r
        x(0) = arrVal: x(1) = arrInd: FILE_Array2xGet1xFromCol = x
    Else
        For r = 1 To UBound(arr2x, 1)
            arrVal(r - 1) = arr2x(r, nCol)
        Next r
        FILE_Array2xGet1xFromCol = arrVal
    End If
End Function