Sub qq()
    Dim oDic As Object, ar, i&
    Set oDic = CreateObject("Scripting.Dictionary")
    With ActiveSheet
        ar = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
' удаляем дубликаты из массива
        For i = 1 To UBound(ar)
            oDic.Item(ar(i, 1)) = oDic.Item(ar(i, 1)) + 1
        Next
        ar = .Range(.Cells(2, 2), .Cells(Rows.Count, 2).End(xlUp)).Value
' удаляем исключения из словаря
        For i = 1 To UBound(ar)
            If oDic.Exists(ar(i, 1)) Then oDic.Remove (ar(i, 1))
        Next
        ar = oDic.keys
        .Cells(2, 3).Resize(oDic.Count) = Application.Transpose(ar)
    End With
End Sub

Sub qq()
    Dim oDic As Object, ar, x, i As Long, LastRow As Long

    'создаём объем Словарь для его последующего использования в формировании уникальных значений
    Set oDic = CreateObject("Scripting.Dictionary")
    
    With ActiveSheet
        'данные из столбца А
        ar = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
        ' удаляем дубликаты из массива
        For i = 1 To UBound(ar)
            oDic.Item(ar(i, 1)) = oDic.Item(ar(i, 1)) + 1
        Next
        'данные из столбца В
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        ar = .Range(.Cells(2, 2), .Cells(2, 2)).Value
        'если в столбце В ничего, кроме заголовка нет, то нечего исключать из массива
        If LastRow > 1 Then
            'удаляем исключения из словаря
            'если в списке 1 позиция, то переводим ar в массив
            If Not IsArray(ar) Then
                ar = Array(ar, 1)
                For Each x In ar
                    If oDic.Exists(x) Then oDic.Remove (x)
                Next x
            Else
                'удаляем исключения из словаря
                For i = LBound(ar, 1) To UBound(ar, 1)
                    If oDic.Exists(ar(i, 1)) Then oDic.Remove (ar(i, 1))
                Next
            End If
        End If
        'перекладываем уникальные ключи из объекта Словарь в массив
        ar = oDic.keys
        'очистка столбца С
        LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
        If LastRow > 1 Then .Range("C2:C" & LastRow).ClearContents
        .Cells(2, 3).Resize(oDic.Count) = Application.Transpose(ar)
    End With
End Sub