Sub Main()
    Dim sh1 As Worksheet: Set sh1 = Workbooks("Ðàñ÷åò_îáùèé.xlsb").Sheets(1)
    Dim sh2 As Worksheet: Set sh2 = ActiveSheet
    
    Dim dicY As Object
    Set dicY = FillDic(sh1)
    
    
    Cells(1, 2).Value = NewVPR(Cells(1, 1).Value, sh1, dicY, 2)
End Sub

Function FillDic(sh As Worksheet) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim a As Variant
    With sh
        a = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    
    Dim y As Long
    For y = 1 To UBound(a, 1)
        dic.Item(a(y, 1)) = y
    Next
    Set FillDic = dic
End Function

Function NewVPR(v As Variant, sh As Worksheet, dic As Object, x As Integer) As Variant
    If dic.Exists(v) Then
        Dim y As Integer
        y = dic.Item(v)
        NewVPR = sh.Cells(y, x).Value
    Else
        NewVPR = CVErr(xlErrNA)
    End If
End Function

a = sh1.UsedRange.Value
    Set sd = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      Key = a(i, 1)
      Item = a(i, 7) 
      sd.Add Key, Item 
    Next

Debug.Print sd.Count

Sub NewVPR()

    Dim a()
    Dim i&
    Dim sd As Object
    Dim sh1 As Worksheet: Set sh1 = Workbooks("Пример.xlsb").Sheets(1)
    Dim sh2 As Worksheet: Set sh2 = ActiveSheet

    a = sh1.UsedRange.Value
    Set sd = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      Key = a(i, 1) ' получаем ключ из первого столбца текущей строки массива
      Item = a(i, 7) ' получаем элемент из седьмого столбца текущей строки массива
      sd.Add Key, Item ' и добавляем новый элемент в коллекцию
    Next
    a = sh2.UsedRange.Value
    For i = 1 To UBound(a)
        If sd.Exists(a(i, 1)) Then a(i, 8) = sd.Item(a(i, 1))

    Next
    sh2.Cells(1, 1).Resize(UBound(a), UBound(a, 2)) = a
End Sub