Option Explicit
'====================================================================================================================
Sub Сравнить2Списка() ' по мотивам BlackBox (http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/rasshirennoe_sravnenie_dvukh_kolonok/7-1-0-20)
Dim rng As Range, txtWB$
Dim dicUniq As Object, dicL As Object, dicR As Object
Dim x, arr1x(), arrOut(), txt$, r&

txtWB = ActiveWorkbook.FullName
Set dicUniq = CreateObject("Scripting.Dictionary")
Set dicL = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")

Set rng = Selection:    If Not FillDictisFromRange(rng, "для сравнения ПЕРВЫЙ (ЛЕВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicL) Then Exit Sub
Set rng = Nothing:      If Not FillDictisFromRange(rng, "для сравнения ВТОРОЙ (ПРАВЫЙ) ДИАПАЗОН:", txtWB, dicUniq, dicR) Then Exit Sub
If dicUniq.count = 0 Then MsgBox "Подходящие ключи не найдены!", vbInformation, "ПУСТО": Exit Sub

arr1x = dicUniq.Keys: Set dicUniq = Nothing
FILE_Sort_Array1x arr1x, 0, UBound(arr1x)

ReDim arrOut(1 To UBound(arr1x) + 2, 1 To 5)
arrOut(1, 1) = "ЗНАЧЕНИЕ"
arrOut(1, 2) = "ГДЕ НАЙДЕНО"
arrOut(1, 3) = "СТАТУС"
arrOut(1, 4) = "СКОЛЬКО СЛЕВА"
arrOut(1, 5) = "СКОЛЬКО СПРАВА"

    For r = 2 To UBound(arrOut, 1)
        x = arr1x(r - 2): arrOut(r, 1) = x

        If dicL.Exists(x) Then arrOut(r, 4) = dicL(x) Else arrOut(r, 4) = 0
        If arrOut(r, 4) < 2 Then txt = "Л" & arrOut(r, 4) Else txt = "Лн"

        If dicR.Exists(x) Then arrOut(r, 5) = dicR(x) Else arrOut(r, 5) = 0
        If arrOut(r, 5) < 2 Then txt = txt & "П" & arrOut(r, 5) Else txt = txt & "Пн"

        arrOut(r, 3) = txt

        If Mid$(txt, 2, 1) = "0" Then
            arrOut(r, 2) = "только СПРАВА"
        Else
            If Right$(txt, 1) = "0" Then
                arrOut(r, 2) = "только СЛЕВА"
            Else
                arrOut(r, 2) = "в ОБОИХ"
            End If
        End If
    Next r

Application.ScreenUpdating = False
Worksheets.Add , ActiveSheet
ActiveWindow.DisplayGridlines = False

Set rng = Cells(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2))
    With rng
        .Font.Name = "Times New Roman"
        .Font.Size = 9
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .ShrinkToFit = True
    End With

    With rng.Rows(1)
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .WrapText = True
        .ShrinkToFit = False
    End With

rng.Borders.LineStyle = True
rng.Value2 = arrOut
ActiveSheet.ListObjects.Add xlSrcRange, rng, , xlYes
rng.AutoFilter

    With Cells(2, 2).Resize(UBound(arrOut, 1), UBound(arrOut, 2) - 1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With

Cells(1, 1).Resize(1, UBound(arrOut, 2)).ColumnWidth = 10
Cells(1, 1).Resize(1, UBound(arrOut, 2)).EntireColumn.AutoFit
If Columns(1).ColumnWidth > 100 Then Columns(1).ColumnWidth = 100

Application.ScreenUpdating = True
MsgBox "Успешно обработано и выявлено уникальных ключей: " & Format$(UBound(arrOut, 1) - 1, "# ##0"), vbInformation, ""
End Sub
'--------------------------------------------------------------------------------------------------------------------
Private Function FillDictisFromRange(ByVal rng As Range, ByVal txtHead$, ByVal txtWB$, dicU As Object, dicLR As Object) As Boolean
Dim ar As Range, arr, x, tmp, bt As Byte

rep: If Not FILE_SelectRange(rng, txtHead) Then Exit Function
If rng.Parent.Parent.FullName <> txtWB Then MsgBox "Оба диапазона для сравнения должны находиться в ОДНОЙ книге (одном файле)", vbCritical, "ОШИБКА ВЫДЕЛЕНИЯ": GoTo rep
Set rng = Intersect(rng, rng.Parent.UsedRange)

    If FILE_HaveHide(rng) Then
        bt = MsgBox("В выделенном диапазоне присутствуют СКРЫТЫЕ ячейки!" & vbLf & "Взять только ВИДИМЫЕ [ДА] или ВСЕ [НЕТ]?", vbYesNoCancel + vbQuestion + vbDefaultButton1)
        If bt = vbCancel Then GoTo rep

        If bt = vbYes Then
            If Not FILE_GetVisible(rng, True) Then GoTo rep
        End If
    End If

If Not FILE_CheckRng(rng, True) Then GoTo rep
If FILE_IsRangeInUsed(rng, , True, True) <> 1 Then GoTo rep
If FILE_IsOneCellInRng(rng, True) Then GoTo rep

    For Each ar In rng.Areas
        arr = ar.Value2: If Not IsArray(arr) Then arr = Array(arr)
        For Each x In arr
            If IsError(x) Then MsgBox "В данных обнаружена ошибка!", vbCritical, "ОШИБКА ДАННЫХ": Exit Function
            If Len(x) And x <> "—" Then tmp = dicU(x): dicLR(x) = dicLR(x) + 1
        Next x
    Next ar

FillDictisFromRange = True
End Function

Option Explicit
Option Private Module
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Рекурсивный сортер 1x-массива в редакции от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=5&TID=114744&TITLE_SEO=114744-poluchenie-spiska-unikalnykh-znacheniy-iz-odnomernogo-massiva-vba&MID=953013&tags=%D0%9F%D0%BE%D0%BB%D1%83%D1%87%D0%B8%D1%82%D1%8C.%D0%B4%D0%B0%D0%BD%D0%BD%D1%8B%D0%B5.%D1%81%D0%B2%D0%BE%D0%B4%D0%BD%D0%BE%D0%B9+%D1%82%D0%B0%D0%B1%D0%BB%D0%B8%D1%86%D1%8B&_r=9788#message953013
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub FILE_Sort_Array1x(arr1x(), l&, u&)
Dim i&, j&, x, y

i = l: j = u: x = arr1x((l + u) \ 2)

        Do
            Do While arr1x(i) < x: i = i + 1: Loop
            Do While x < arr1x(j): j = j - 1: Loop
            If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
        Loop Until i > j

If l < j Then FILE_Sort_Array1x arr1x, l, j
If i < u Then FILE_Sort_Array1x arr1x, i, u
End Sub
'====================================================================================================
Function FILE_SelectRange(rng As Range, Optional txtTitle$ = "ДИАПАЗОН") As Boolean
Dim cl As Range, SA As Boolean

SA = Application.ScreenUpdating: Application.ScreenUpdating = True
If rng Is Nothing Then Set rng = Selection
On Error Resume Next: Set cl = Application.InputBox("Выделите мышкой " & txtTitle, "ВЫДЕЛЕНИЕ ДИАПАЗОНА", Replace$(rng.Address, ",", ";"), Type:=8)
If Err.Number <> 0 Then GoTo fin Else On Error GoTo 0

Set rng = cl: FILE_SelectRange = True
fin: On Error GoTo 0: Application.ScreenUpdating = SA
End Function
'====================================================================================================
'====================================================================================================
Function FILE_CheckRangeFull(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If Not FILE_CheckRng(rng, MsgIfFalse) Then Exit Function
If FILE_HaveHide(rng, MsgIfFalse, False) Then Exit Function
If FILE_HaveMerge(rng, MsgIfFalse) Then Exit Function Else FILE_CheckRangeFull = True
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CheckRng(rng As Range, Optional MsgIfFalse As Boolean) As Boolean
If TypeName(rng) <> "Range" Then GoTo er
If rng Is Nothing Then GoTo er
If rng.Cells.count < 1 Then GoTo er
If IsError(rng) Then GoTo er
If rng.Parent.ProtectContents = True Then GoTo er
FILE_CheckRng = True: Exit Function
er: If MsgIfFalse Then MsgBox "Диапазон некорректен!", vbCritical, "FILE_CheckRng"
End Function
'====================================================================================================
Function FILE_HaveHide(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
    If FILE_CountHide(rng) > 0 Then
        FILE_HaveHide = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
    Else
        If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ СКРЫТЫЕ ячейки!", vbCritical, "FILE_HaveHide"
    End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_HaveVisible(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
    If rng.count > FILE_CountHide(rng) Then
        FILE_HaveVisible = True: If MsgIfTrue Then MsgBox "В диапазоне ПРИСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
    Else
        If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_HaveVisible"
    End If
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_CountHide(rng As Range) As Long
Dim vis&
    If rng.count = 1 Then
        If rng.EntireRow.Hidden Or rng.EntireColumn.Hidden Then FILE_CountHide = 1
        Exit Function
    End If
On Error Resume Next: FILE_CountHide = rng.count - rng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0
End Function
'----------------------------------------------------------------------------------------------------
Function FILE_GetVisible(tmpRng As Range, Optional MsgIfFalse As Boolean) As Boolean
Dim vis&
    If tmpRng.count = 1 Then
        If tmpRng.EntireRow.Hidden Or tmpRng.EntireColumn.Hidden Then GoTo no Else GoTo yes
    End If
On Error Resume Next: vis = tmpRng.SpecialCells(xlCellTypeVisible).count: On Error GoTo 0: If vis = 0 Then GoTo no
Set tmpRng = tmpRng.SpecialCells(xlCellTypeVisible)

yes: FILE_GetVisible = True: Exit Function
no: If MsgIfFalse Then MsgBox "В диапазоне ОТСУТСТВУЮТ ВИДИМЫЕ ячейки!", vbCritical, "FILE_GetVisible"
End Function
'====================================================================================================
Function FILE_HaveMerge(rng As Range, Optional MsgIfTrue As Boolean) As Boolean
If rng.MergeCells = False Then Exit Function Else FILE_HaveMerge = True
If MsgIfTrue Then MsgBox "В диапазоне присутствуют ОБЪЕДИНЁННЫЕ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsOneAreaInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
    If rng.Areas.count = 1 Then
        FILE_IsOneAreaInRng = True: If MsgIfTrue Then MsgBox "Диапазон содержит ОДНУ область!", vbCritical, "ОШИБКА ДИАПАЗОНА"
    Else
        If MsgIfFalse Then MsgBox "Диапазон содержит БОЛЕЕ ОДНОЙ области!", vbCritical, "ОШИБКА ДИАПАЗОНА"
    End If
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneCellInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
If rng.Cells.count = 1 Then FILE_IsOneCellInRng = True Else GoTo ex
If MsgIfTrue Then MsgBox "Не менее ДВУХ ячеек!", vbCritical, "ОШИБКА ДИАПАЗОНА": Exit Function Else Exit Function
ex: If MsgIfFalse Then MsgBox "Не более ОДНОЙ ячейки!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'-------------------------------------------------------------------------------------------
Function FILE_IsOneColumnInRng(rng As Range, Optional MsgIfTrue As Boolean, Optional MsgIfFalse As Boolean) As Boolean
Dim ar As Range, cl As Range, col&
col = rng.Cells(1, 1).Column
    For Each ar In rng.Areas
        If ar.Cells(1, 1).Column <> col Or ar.Columns.count <> 1 Then
            If MsgIfFalse Then MsgBox "Диапазон содержит более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
            Exit Function
        End If
    Next ar
FILE_IsOneColumnInRng = True: If MsgIfTrue Then MsgBox "Диапазон должен содержать более ОДНОГО столбца!", vbCritical, "ОШИБКА ДИАПАЗОНА"
End Function
'====================================================================================================
Function FILE_IsRangeInUsed(tmpRng As Range, Optional MsgIfFull As Boolean, Optional MsgIfPart As Boolean, Optional MsgIfOut As Boolean) As Integer ' -1 = полностью снаружи, 0 = пересекается, 1 = полностью внутри
Dim rngU As Range, rngI As Range

FILE_IsRangeInUsed = -1
Set rngU = tmpRng.Parent.UsedRange
Set rngI = Intersect(tmpRng, rngU)

    If rngI Is Nothing Then
        Set tmpRng = rngU
        If MsgIfOut Then MsgBox "Выделенный диапазон ЦЕЛИКОМ СНАРУЖИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
    ElseIf rngI.Address = tmpRng.Address Then
        FILE_IsRangeInUsed = 1
        If MsgIfFull Then MsgBox "Выделенный диапазон ЦЕЛИКОМ ВНУТРИ рабочей области листа!", vbExclamation, "FILE_IsRangeInUsed"
    Else
        FILE_IsRangeInUsed = 0
        Set tmpRng = rngI
        If MsgIfPart Then MsgBox "Выделенный диапазон ЧАСТИЧНО СОВПАДАЕТ с рабочей областью листа!", vbExclamation, "FILE_IsRangeInUsed"
    End If
End Function
'====================================================================================================