Sub Найти_дубли()

    Dim collA As New Collection, arrB(), collRes As New Collection
    Dim arr(), lr As Long, i As Long
    
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    arr() = Range("A1:A" & lr).Value
    On Error Resume Next
    For i = 2 To UBound(arr)
        collA.Add Item:="", key:=CStr(arr(i, 1))
    Next i
    On Error GoTo 0
    
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arrB() = Range("B1:B" & lr).Value
    
    On Error Resume Next
    For i = 2 To UBound(arrB)
        If collA(CStr(arrB(i, 1))) = "" Then
        End If
        If Err.Number = 0 Then
            collRes.Add Item:=arrB(i, 1), key:=CStr(arrB(i, 1))
            If Err.Number <> 0 Then
                Err.Number = 0
            End If
        Else
            Err.Number = 0
        End If
    Next i
    On Error GoTo 0
    
    If collRes.Count = 0 Then
        MsgBox "Готово!", vbInformation
        Exit Sub
    End If
    
    ReDim arr(1 To collRes.Count, 1 To 1)
    For i = 1 To collRes.Count
        arr(i, 1) = collRes(i)
    Next i
    Range("C2").Resize(UBound(arr)).Value = arr()
    MsgBox "Готово!", vbInformation
    
End Sub