Function ВПР_1(Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range) As Variant
Dim Диапазон_для_поиска()
Dim Диапазон_Справочника()
Dim Addr$
Dim wb As Workbook
Dim SLOVOPOLN As String
Dim dic As New Scripting.Dictionary
Dim СправочникСтолцов As New Scripting.Dictionary
Dim c(), cel As Range, STOLB%, Столбцы_вывода, stolbStart%, i#, SLOVO$
dic.CompareMode = TextCompare

Диапазон_для_поиска = Диапазон_для_поиска_диапазон.Value
Диапазон_Справочника = Диапазон_Справочника_диапазон.Value

'    Получаем список уникальных столбцов
    With СправочникСтолцов
        For Each cel In Столбцы_вывода_диапазон
            STOLB = cel.Column - Диапазон_Справочника_диапазон.Column + 1
            If Not .Exists(STOLB) Then .Add STOLB, STOLB
        Next
    Столбцы_вывода = .Items
    End With
    
    stolbStart = Столбец_информации.Column - Диапазон_Справочника_диапазон.Column + 1
    ReDim c(1 To UBound(Диапазон_для_поиска), 1 To UBound(Столбцы_вывода) + 1)
    With dic
        For i = 1 To UBound(Диапазон_Справочника)
        If Not .Exists(Диапазон_Справочника(i, stolbStart)) Then .Add Диапазон_Справочника(i, stolbStart), i
        Next
        
        For i = 1 To UBound(Диапазон_для_поиска)
        SLOVO = CStr(Диапазон_для_поиска(i, 1))
        If Len(SLOVO) Then
            If .Exists(SLOVO) Then
                For STOLB = 0 To UBound(Столбцы_вывода)
                c(i, STOLB + 1) = Диапазон_Справочника(.Item(SLOVO), Столбцы_вывода(STOLB))
                Next
            End If
        End If
        Next
    End With
        ВПР_1 = c
End Function

Sub ВПР_test()
Dim Диапазон_для_поиска_диапазон As Range, Диапазон_Справочника_диапазон As Range, _
Столбец_информации As Range, Столбцы_вывода_диапазон As Range, Столбец_вывода_Информации_диапазон As Range
Dim массив
Set Диапазон_для_поиска_диапазон = Application.InputBox("Диапазон_для_поиска_диапазон", Default:=[j2:j5].AddressLocal, Type:=8)
Set Столбец_вывода_Информации_диапазон = Application.InputBox("Столбец_вывода_Информации_диапазон", Default:=Диапазон_для_поиска_диапазон.Offset(, 1).AddressLocal, Type:=8)
'можно выделить несколько ячеек сразу - для этого нажать ctrl  и выбрать нужные столбцы мышью

Set Диапазон_Справочника_диапазон = Application.InputBox("Диапазон_Справочника_диапазон", Default:=[a1:e100].AddressLocal, Type:=8)
Диапазон_Справочника_диапазон.Parent.Parent.Activate: Диапазон_Справочника_диапазон.Parent.Activate

Set Столбец_информации = Application.InputBox("Столбец_информации", Default:=[c3].AddressLocal, Type:=8)
Set Столбцы_вывода_диапазон = Application.InputBox("Столбцы_вывода_диапазон", Default:=Range("$A$7:A10,$C$7,$E$7").AddressLocal, Type:=8)

массив = ВПР_1(Диапазон_для_поиска_диапазон, Диапазон_Справочника_диапазон, Столбец_информации, Столбцы_вывода_диапазон)

Столбец_вывода_Информации_диапазон.Parent.Parent.Activate: Столбец_вывода_Информации_диапазон.Parent.Activate
Столбец_вывода_Информации_диапазон.Cells(1, 1).Resize(UBound(массив), UBound(массив, 2)) = массив

End Sub