Sub Get_Data_Dictionary()
    Dim SourceWB As Workbook, FSO As Object, Dict As Object, sSourceFileName As String, sPathToSourceFile As String
    Dim arrSource, arrResult, arrTemp, i As Long, iPos As Long

    sSourceFileName = "Source.xlsm" 'название файла источника
    
    sPathToSourceFile = ThisWorkbook.Path & Application.PathSeparator & sSourceFileName
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FileExists(sPathToSourceFile) Then
        MsgBox "Файл '" & sSourceFileName & "' не найден!", vbExclamation, "Внимание"
        Exit Sub
    End If
    Set FSO = Nothing
    Application.ScreenUpdating = False
    Set SourceWB = Workbooks.Open(sPathToSourceFile, UpdateLinks:=False, ReadOnly:=True)
    With SourceWB.Worksheets(1)
        arrSource = .Range("C2:F" & .Cells(.Rows.Count, 3).End(xlUp).Row).Value 'все данные из базы
    End With
    SourceWB.Close (False)
    With ThisWorkbook.Worksheets(1)
        If .AutoFilterMode = True Then .ShowAllData
        arrTemp = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value 'по этим данным будем вести поиск
        ReDim arrResult(1 To UBound(arrTemp), 1 To 1)
        Set Dict = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(arrSource)
            If Not Dict.Exists(arrSource(i, 1)) Then Dict.Item(arrSource(i, 1)) = i
        Next
        For i = 1 To UBound(arrTemp)
            If Dict.Exists(arrTemp(i, 1)) Then
                iPos = Dict.Item(arrTemp(i, 1))
                arrResult(i, 1) = arrSource(iPos, 4) '4 - номер столбца, из которого берём данные
            Else
                arrResult(i, 1) = CVErr(xlErrNA) '"Данных нет"
            End If
        Next
        .Range("C1").Resize(UBound(arrResult, 1), UBound(arrResult, 2)) = arrResult
    End With
    Set Dict = Nothing
    Application.ScreenUpdating = True
    'MsgBox "Данные подтянуты", vbInformation, "Конец"
End Sub

Dim Conn As ADODB.Connection, RS As ADODB.Recordset
Const FileName = "Source.xlsm"

Function GetPayer(Rng As Range) As Variant
    Dim FilePath As String
            
    FilePath = ThisWorkbook.Path & Application.PathSeparator

    If Conn Is Nothing Then Set Conn = New ADODB.Connection
    Conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & FilePath & FileName & ";" & _
        "Extended Properties='Excel 12.0 Macro;HDR=YES';"
    Conn.Open

    If RS Is Nothing Then Set RS = New ADODB.Recordset
    With RS
        .ActiveConnection = Conn
        .Source = "SELECT [Плательщик] FROM [Лист1$] WHERE [Договор] = '" & Rng.Cells(1).Value & "'"
        .CursorLocation = 3 'adUseClient
        .Open
    End With
            
    Select Case RS.RecordCount
        Case 0
            GetPayer = CVErr(xlErrNA)
        Case 1
            GetPayer = RS.Fields("Плательщик").Value
        Case Is > 1
            GetPayer = RS.Fields("Плательщик").Value
    End Select
    
    RS.Close
    Conn.Close
End Function