Sub DictITM()
    Dim a, c, lr As Long
    Dim i%, j%, n%, shName$, FUTSEAT As Long
    Dim Rng As Range, FR As Range, SR As Range
    Dim ArrStr As Variant
    Dim ArrSeat As Variant
    Dim ArrSh As Variant

    With Application
        .ScreenUpdating = False     'отключение обновление экрана
        .Calculation = xlCalculationManual  'отключение пересчёт формул вручную
        .DisplayAlerts = False                   'отключение предупреждающих сообщений
    End With
    '.............................................
    Set Rng = ThisWorkbook.Sheets("BPC").Range("k1:k10")
    Set SR = Rng.Find("SETT.PRICE")
    SR.Offset(1, 0).Copy ThisWorkbook.Sheets("BPP").[K1]

    Set Rng = ThisWorkbook.Sheets("ECC").Range("k1:k10")
    Set SR = Rng.Find("SETT.PRICE")
    SR.Offset(1, 0).Copy ThisWorkbook.Sheets("ECP").[K1]
    '..............................................

    ArrSh = Array("BPC", "BPP", "ECC", "ECP")

    For n = 0 To UBound(ArrSh)
        shName = ArrSh(i)
        'With Sheets(shName)

        If shName = "BPC" Or shName = "ECC" Then
            Set FUT = Range("K1:K10").Find("SETT.PRICE")
            FUTSEAT = FUT.Offset(1, 0).Value

        ElseIf shName = "BPP" Or shName = "ECP" Then
            FUTSEAT = [K1].Value
        End If

        Set Rng = Range("K1:K20")
        Set FR = Rng.Find("SETTLE_bs")

        If Not FR Is Nothing Then

            With CreateObject("Scripting.Dictionary")
                'данные в массив
                With Sheets(shName)
                    iLastrow = .Cells(FR.Rows.Count, 1).End(xlUp).Row
                    a = .Range(FR.Offset(1, 0), FR.Offset(lr, 7)).Value
                End With
                'в словарь номера и "яблоки"
                For i = 1 To UBound(a)
                    .Item(a(i, 1)) = a(i, 7)
                Next


                'пустой массив для результата
                ReDim c(1 To UBound(a), 1 To 1)

                'из словаря в массив c (c расчётами по ходу)

                For i = 1 To UBound(a)
                    If shName = "BPC" Or shName = "ECC" Then
                        If IsNumeric(a(i, 7)) Then
                            If (FUTSEAT - .Item(a(i, 1))) > 0 Then
                                c(i, 1) = FUTSEAT - .Item(a(i, 1))
                            Else: If (FUTSEAT - .Item(a(i, 1))) < 0 Then c(i, 1) = 0
                            End If
                        End If
                    End If

                    If shName = "BPP" Or shName = "ECP" Then
                        If IsNumeric(a(i, 7)) Then
                            If (.Item(a(i, 1)) - FUTSEAT) > 0 Then
                                c(i, 1) = .Item(a(i, 1)) - FUTSEAT
                            Else
                                If (.Item(a(i, 1)) - FUTSEAT) < 0 Then c(i, 1) = 0
                            End If
                        End If
                    End If
                Next

            End With
            'выгрузка всего собранного массива
            Range(FR.Offset(1, 3), FR.Offset(lr, 3)) = c

        End If
    Next n

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub


 

 Sub DictITM()
    Dim a, c, lr As Long
    Dim i%, j%, n%, shName$, FUTSEAT As Long
    Dim Rng As Range, FR As Range, SR As Range
    Dim ArrStr As Variant
    Dim ArrSeat As Variant
    Dim ArrSh As Variant

    With Application
        .ScreenUpdating = False     'отключение обновление экрана
        .Calculation = xlCalculationManual  'отключение пересчёт формул вручную
        .DisplayAlerts = False                   'отключение предупреждающих сообщений
    End With
    '.............................................
    Set Rng = ThisWorkbook.Sheets("BPC").Range("k1:k10")
    Set SR = Rng.Find("SETT.PRICE")
    SR.Offset(1, 0).Copy ThisWorkbook.Sheets("BPP").[K1]

    Set Rng = ThisWorkbook.Sheets("ECC").Range("k1:k10")
    Set SR = Rng.Find("SETT.PRICE")
    SR.Offset(1, 0).Copy ThisWorkbook.Sheets("ECP").[K1]
    '..............................................

    ArrSh = Array("BPC", "BPP", "ECC", "ECP")

    For n = 0 To UBound(ArrSh)
        shName = ArrSh(n)

        If shName = "BPC" Or shName = "ECC" Then
            Set FUT = Sheets(shName).Range("K1:K10").Find("SETT.PRICE")
            FUTSEAT = FUT.Offset(1, 0).Value

        ElseIf shName = "BPP" Or shName = "ECP" Then
            FUTSEAT = [K1].Value
        End If


        Set Rng = Sheets(shName).Range("K1:K20")
        Set FR = Rng.Find("SEATTLE_bs")

        If Not FR Is Nothing Then

            With CreateObject("Scripting.Dictionary")
                'данные в массив
                With Sheets(shName)
                    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                    a = .Range(FR.Offset(1, 0), FR.Offset(lr, 7)).Value
                End With
                'в словарь номера и "яблоки"
                For i = 1 To UBound(a)
                    .Item(a(i, 1)) = a(i, 7)
                Next


                'пустой массив для результата
                ReDim c(1 To UBound(a), 1 To 1)

                'из словаря в массив c (c расчётами по ходу)

                For i = 1 To UBound(a)
                    If shName = "BPC" Or shName = "ECC" Then
                        If IsNumeric(a(i, 7)) Then
                            If (FUTSEAT - .Item(a(i, 1))) > 0 Then
                                c(i, 1) = FUTSEAT - .Item(a(i, 1))
                            Else: If (FUTSEAT - .Item(a(i, 1))) < 0 Then c(i, 1) = 0
                            End If
                        End If
                    End If

                    If shName = "BPP" Or shName = "ECP" Then
                        If IsNumeric(a(i, 7)) Then
                            If (.Item(a(i, 1)) - FUTSEAT) > 0 Then
                                c(i, 1) = .Item(a(i, 1)) - FUTSEAT
                            Else
                                If (.Item(a(i, 1)) - FUTSEAT) < 0 Then c(i, 1) = 0
                            End If
                        End If
                    End If
                Next

            End With
            'выгрузка всего собранного массива
            Range(FR.Offset(1, 3), FR.Offset(lr, 3)) = c

        End If
    Next n

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub