With Лист1.Range("A3")

        For i = 1 To UBound(s)
            .Item(s(i, 1)) = i
             Next

  c(p, 10) = s(i, 17)

Sub ИнстрРеж() ' не используется
    Dim a, c, s, p&, iLastrow As Long, i As Long, ii As Long, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    '1. данные в два массива
    With Лист2    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        a = Range(.[B3], .Range("i" & iLastrow)).Value
    End With

    With Лист3    ' остатки
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        s = Range(.[B2], .Range("AH" & iLastrow)).Value
    End With
    
    '2.пустой массив для результата
    ReDim c(1 To UBound(s), 1 To 11)

    With d
        
        '3.в словарь уникальные и номер строки из массива
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = i
        Next
        '4.по словарю из массива s в массив c
        For i = 1 To UBound(s)
            If .Exists(s(i, 1)) Then
                p = p + 1
                c(p, 1) = p
                c(p, 2) = s(i, 1)
                c(p, 3) = s(i, 3)
                c(p, 4) = s(i, 4)
                c(p, 5) = s(i, 8)
                c(p, 6) = s(i, 9)
                c(p, 7) = s(i, 12)
                c(p, 8) = s(i, 11)
                c(p, 9) = s(i, 15)
                c(p, 10) = s(i, 17) * a(d(s(i, 1)), 8)
            End If
        Next
    End With
    '5. выгрузка всего массива
    With Лист1.Range("A3:J3") 'используется кодовое имя
        .CurrentRegion.Offset(2).ClearContents
        .Resize(UBound(c), 11) = c
    End With
End Sub