Private Sub SearchByList()
'' Author:  boa
'' Written: 20.10.2017
'' Edited:
'  Description: Берет данные из заданного диапазона искомых значений(Словаря) и сравнивает их со списком значений,
'               если находит совпадения, то переносит все уникальные значения из заданного столбца
'               и сопоставленное ему значение из Словаря в новую книгу.
    
    Dim MyList As Range         'Список искомых значений
    Dim MyRange As Range        'Диапазон для поиска
    Dim SearchColumn As Integer 'колонка в которой ищем совпадения
    Dim ZnachColumn As Integer  'колонка из которой нужно вывести значения
    Dim iRow&, V$, Znach As Variant
    Dim strCaption$, strLabel$
    
    On Error GoTo Proverka
    strCaption = "Поиск уникальных значений по списку"
    strLabel = "Введите ссылку на список значений которые надо найти(Словарь)." & vbCrLf & _
               "Будут учитываться только видимы значения из выбранного диапазона."
    Set MyList = Application.InputBox(Prompt:=strLabel, Title:=strCaption, Type:=8)
    strLabel = "Введите ссылку на диапазон содержащий искомые значения и колонку для сопоставления со Словарем."
    Set MyRange = Application.InputBox(Prompt:=strLabel, Title:=strCaption, Type:=8)
    If Not MyRange Is Nothing Then SearchColumn = MyRange.Columns.Count
    strLabel = "Введите номер колонки от 1 до " & SearchColumn & " в выбранном диапазоне, по которой должен быть произведен поиск значений из Словаря."
    SearchColumn = Application.InputBox(Prompt:=strLabel, Title:=strCaption, Default:=SearchColumn, Type:=1)
    
    strLabel = "Введите номер колонки в массиве из которой надо вывести найденный результат." & vbCrLf & _
               "Если номер колонки не вводить(нажать ""Отмена""), то в результат будет выведена вся строка из выделенного диапазона."
    ZnachColumn = Application.InputBox(Prompt:=strLabel, Title:=strCaption, Type:=1)
Proverka:
    If MyList Is Nothing Or MyRange Is Nothing Or SearchColumn < 1 Then _
        MsgBox "Не введены все обязательные параметры для поиска значений.", vbCritical, "": Exit Sub
    
    Dim Start!, sMsg$
    Start! = Timer
    
    Dim i&, a As Range, DicSearch As Object, Dic As Object
    
    Set DicSearch = CreateObject("Scripting.Dictionary")
    Set Dic = CreateObject("Scripting.Dictionary")
'    DicSearch.CompareMode = vbTextCompare
'    Dic.CompareMode = vbTextCompare   'Что бы сделать ключи не чуствительными к регистру. _
'                    vbBinaryCompare - по умолчанию. "File", "FILE" и "file"  три разных ключа

On Error Resume Next
    For Each a In MyList    'Список искомых значений
      If a.Rows.Hidden = False Then DicSearch.Add CStr(a.Value), a.Value
    Next a
    
    For i = 1 To MyRange.Rows.Count 'Список найденных значений
      If DicSearch.Exists(CStr(MyRange.Cells(i, SearchColumn).Value)) Then
        If ZnachColumn > 0 Then V = CStr(MyRange.Cells(i, ZnachColumn).Value) Else V = i
        Dic.Add V, CStr(MyRange.Cells(i, SearchColumn).Value)
      End If
    Next i
    
    With Workbooks.Add(xlWBATWorksheet).Worksheets(1)   'вывод результатов
        .Cells(1, 1).Value = "Значения из списка"
        .Cells(1, 2).Value = "Найденные значение " & Dic.Count
        iRow = 2
        If ZnachColumn > 0 Then
            .Range(.Cells(iRow, 1), .Cells(Dic.Count + 1, 2)).Value = Application.Transpose(Array(Dic.Items, Dic.Keys))
        Else
            .Range(.Cells(iRow, 1), .Cells(Dic.Count + 1, 1)).Value = Application.Transpose(Array(Dic.Items))
            For Each Znach In Dic
                .Range(.Cells(iRow, 2), .Cells(iRow, MyRange.Columns.Count + 1)).Value = MyRange.Rows(Znach).Value
                iRow = iRow + 1
            Next
        End If
        .UsedRange.EntireColumn.AutoFit
    End With
    
    sMsg = "Для заданного списка найдено " & Dic.Count & " значений." & vbCrLf & _
           "Затрачено " & Format(Timer - Start, "0.00") & " сек."
    Debug.Print "Затрачено: " & Timer - Start
    MsgBox sMsg, vbInformation
End Sub