Sub FilterAndSort()
    With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
    Dim contr, arrIndex(), lt&, dic As Object
    Dim data As Worksheet, res As Worksheet
    Set data = ThisWorkbook.Sheets(1)
    Set res = ThisWorkbook.Sheets("результат")
    
    Set dic = CreateObject("scripting.dictionary")
    With data
        For i = 2 To .Cells(Rows.Count, "f").End(xlUp).Row
            If Not dic.exists(Trim(.Cells(i, "f"))) Then dic.Add Trim(.Cells(i, "f")), i - 1
        Next i
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        contr = .Range("b2:b" & lr).Value
        ReDim arrIndex(UBound(contr) - 1, 0)
        For i = 1 To UBound(contr)
            If dic.exists(Trim(contr(i, 1))) Then
                arrIndex(i - 1, 0) = dic.Item(Trim(contr(i, 1)))
            Else
                arrIndex(i - 1, 0) = ""
            End If
        Next i
    End With
    
    With res
        .Range("a1:e" & .Cells(Rows.Count, 1).End(xlUp).Row).Clear
        data.Range("a1:d" & lr).Copy .[a1]
        .[e2].Resize(lr - 1) = arrIndex
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("e2:e" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange res.Range("a2:e" & lr)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(.Cells(WorksheetFunction.CountA(.Range("e2:e" & lr)) + 2, 1), .Cells(lr, "d")).Clear
        .Range("e2:e" & lr).Clear
    End With
    With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
End Sub

Обработка: (*) скопировать результат в другое место

Исходный диапазон: $A$1:$D$15
Диапазон условий: $F$1:$F$6
Поместить результат в диапазон: $H$1:$K$1

Только уникальные записи: пусто

ОК

Sub Макрос1()
    Range("A1:D15").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F6"), _
        CopyToRange:=Range("H1:K1"), _
        Unique:=False
End Sub

Sub selectData()
    
    Dim rst As Object
            
    Set rst = CreateObject("ADODB.Recordset")
            
    rst.Open _
    "SELECT * FROM [Лист1$A1:D65000] WHERE [Контрагент] IN (" & _
    "SELECT [Контрагент] FROM [Лист1$F1:F65000] WHERE Not IsNull([Контрагент])" & _
    ") ORDER BY 1, 2, 3, 4" _
    , _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & ThisWorkbook.FullName & ";" & _
    "Extended Properties='Excel 12.0;HDR=Yes'"
           
    [Лист1!H2].Resize(65000, 4).ClearContents
    [Лист1!H2].CopyFromRecordset rst

End Sub