Sub ertert()
Dim tm!: tm = Timer
Dim x, y(), i&, j&
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value
ReDim y(1 To UBound(x), 1 To 1)
With CreateObject("Scripting.Dictionary")
     For i = 1 To UBound(x)
         .Item(x(i, 1)) = Empty
     Next i
     x = Range("C1", Cells(Rows.Count, 3).End(xlUp)).Value
     For i = 1 To UBound(x)
         If .Exists(x(i, 1)) Then j = j + 1: y(j, 1) = x(i, 1)
     Next i
End With
If j > 0 Then Range("B1").Resize(j).Value = y() Else MsgBox "???????? ???", 64
MsgBox Timer - tm
End Sub

Sub myDuplikat()
Dim oDict: Set oDict = CreateObject("Scripting.Dictionary")  ' Создаем словарь
Dim Arr(), i
Dim t: t = Timer:
Arr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
With oDict
     On Error Resume Next
          
     For i = 1 To UBound(Arr)
         .Add Key:=Arr(i, 1), Item:=True
     Next
      
     Arr = Range("C1:C" & Cells(Rows.Count, 3).End(xlUp).Row)
     For i = 1 To UBound(Arr)
         If .exists(Arr(i, 1)) Then .Item(Arr(i, 1)) = False
     Next
      
     Arr = .keys
      
     For i = 0 To UBound(Arr)
         If .Item(Arr(i)) Then .Remove Arr(i)
     Next
      
     If .Count Then
         Arr = .keys
         If UBound(Arr) < 63000 Then
                Range("B1").Resize(UBound(Arr) + 1) = WorksheetFunction.Transpose(Arr)
         Else
             ReDim mArr(UBound(Arr), 0)
             For i = 0 To UBound(Arr)
                 mArr(i, 0) = Arr(i)
             Next
             Range("B1").Resize(UBound(mArr) + 1) = mArr
         End If
     End If
End With
Debug.Print Timer - t
End Sub