Sub CopyRange()Dim FR As Long, LR As Long, A(), i&, II&, X As Byte, tmp$With Sheets("Лист1")FR = Application.Match(1, Range("AV1:AV100000"), 0)LR = .Cells(Rows.Count, 42).End(xlUp).RowA = Range(Cells(FR, 40), Cells(LR, 48))End With   ReDim b(1 To UBound(A), 1 To 9)   With CreateObject("Scripting.Dictionary")       For i = 1 To UBound(A)           tmp = A(i, 9)    '9 Столбец ключ уникальных значений           If Not .Exists(tmp) Then               .Item(tmp) = vbNullString               II = II + 1               For X = 1 To 3: b(II, X) = A(i, X): Next     '1 To 3 Столбцы для переноса           End If       Next   End WithSheets("Лист2").Range("AF14").Resize(II, 3) = b   '3 Кол-во нужных столбцовEnd Sub

Sub Test()
FastBegin
Dim S As Double
S = Now

Dim BinosozDB As Variant, BinoDB As Variant, Result As Variant, t As Variant, BinosozLR As String, BinoLR As String, i As Long, j As Long
Dim sl: Set sl = CreateObject("Scripting.Dictionary")

With Sheets("Database")
BinosozLR = .Cells(.Rows.Count, "AH").End(xlUp).Row
BinosozDB = .Range(.Cells(14, 2), .Cells(BinosozLR, 34))
End With

With Sheets("BINO")
BinoLR = .Cells(.Rows.Count, "C").End(xlUp).Row
BinoDB = .Range(.Cells(14, 1), .Cells(BinoLR, 6))
Result = .Range(.Cells(14, 7), .Cells(BinoLR, 7))

For i = 14 To BinosozLR
    sl(BinosozDB(i, 1) & BinosozDB(i, 3)) = BinosozDB(i, 32)
Next i

For j = 14 To BinoLR
    t = BinoDB(j, 1) & Left(BinoDB(j, 3), 250)
    If sl.Exists(t) Then
        Result(j, 1) = sl(t)
   End If
Next j

.Range(.Cells(14, 7), .Cells(BinoLR, 7)) = Result
End With

FastEnd
MSGBOX Now - S, 64
End Sub 

Range("P14:P20000").Formula ="=IFERROR(INDEX(R14C12:R20000C12,MATCH(INDEX(R1C1:R20000C1,ROW())&LEFT(INDEX(R1C3:R20000C3,ROW()),250),R14C11:R20000C11,0)),"""")"

Sub Test()
FastBegin
Dim S As Double
S = Now

Dim From As Variant, Into As Variant, Result As Variant, LastRow1 As String, LastRow2 As String, i As Long, j As Long

LastRow1 = Cells(Rows.Count, "K").End(xlUp).Row
LastRow2 = Cells(Rows.Count, "C").End(xlUp).Row

From = Range(Cells(1, 11), Cells(LastRow1, 12))
Into = Range(Cells(1, 1), Cells(LastRow2, 3))
Result = Range(Cells(1, 20), Cells(LastRow2, 20))

For i = 1 To LastRow1
For j = 1 To LastRow2
    If From(i, 1) = Into(j, 1) & Left(Into(j, 3), 250) Then
        Result(j, 1) = From(i, 2)
        Exit For
     End If
 Next j
Next i

Range(Cells(1, 20), Cells(LastRow2, 20)).Value = Result

FastEnd
MSGBOX Now - S, 64 ' результат 22 секунды
End Sub

Sub Get_Value_From_Close_Book_Formula()    
Dim sPath As String, sFile As String, sShName As String, WB As Workbook
    sPath = "C:\Documents and Settings\" '"
    sFile = "Книга1.xls" '"
    sShName = "Лист1" '"
    Application.DisplayAlerts = 0
    Range("A1:A100").Formula = "='" & sPath & "[" & sFile & "]" & sShName & "'!" & "A1" '"
    
    For Each WB In Workbooks
    If WB.Name = "Книга1.xls" Then
    Range("A1:A100").Formula = "='" & sPath & "Выбрать лист" & "'!" & "A1" '"
    End If
    Next
    
    Application.DisplayAlerts = 1
End Sub

Workbooks(sFile).Close True

Sub Get_Value_From_Close_Book_Formula()
    Dim sPath As String, sFile As String, sShName As String
    sPath = "C:\Documents and Settings\" '"
    sFile = "Книга1.xls" '"
    sShName = "Лист1" '"
    Application.DisplayAlerts = 0
    With Range("A1:A100")
        .Formula = "='" & sPath & "[" & sFile & "]" & sShName & "'!" & "A1" '"
        '"A1" - указывается начальная ячейка диапазона, из которого необходимо получить значения
        .Value = .Value
    End With
    Application.DisplayAlerts = 1
End Sub