Sub jjj()
    Set rng_cur_cult_v = Range(Cells(10, 4), Cells(10, 4).End(xlDown)) ' культуры по столбцу
    Set rng_cur_cult_h = Range(Cells(6, 5), Cells(6, 4).End(xlToRight)) ' культуры в шапке
    Range(Cells(11, 5), Cells(Cells(10, 4).End(xlDown).Row, Cells(6, 4).End(xlToRight).Column)).ClearContents ' _
        очищаем стар. дан.
    With Worksheets("Справочник"): Set rng_cur_w_prev = .Range(.Cells(9, 2), .Cells(Rows.Count, 2).End(xlUp)): End With ' _
        область поиска культуры из шапки в справочнике
    Set dic_addr = CreateObject("scripting.dictionary")
    For Each cl_cc In rng_cur_cult_h ' перебор культур в шапке
        S! = cl_cc.Offset(2).Value ' запомнили площадь
        S_inc! = 0 ' суммируемая площадь
        s_cc$ = cl_cc.Value ' запомнили текущую культуры
        Set cl_cc_dic = rng_cur_w_prev.Find(what:=s_cc, after:=rng_cur_w_prev(1), LookIn:=xlValues, _
            lookAt:=xlWhole, searchOrder:=xlByRows, searchDirection:=xlNext, MatchCase:=False, matchByte:=False) ' _
                ищем яч. с тек. культ. в справ.
        If Not cl_cc_dic Is Nothing Then ' если результат поиска не пустой
            Set cl_cult_w_rang = cl_cc_dic.Offset(1, 1) ' первая яч. в рейт. предш. культ.
            Do While Len(cl_cult_w_rang.Value) > 0 ' цикл, пока яч. в рейт. предш. культ. не пустая
                s_cc$ = cl_cult_w_rang.Value ' запомнили текущую культуры
                Set cl_cc_v = rng_cur_cult_v.Find(what:=s_cc, after:=rng_cur_cult_v(1), LookIn:=xlValues, _
                    lookAt:=xlWhole, searchOrder:=xlByRows, searchDirection:=xlNext, MatchCase:=False, matchByte:=False) ' _
                        ищем яч. с тек. культ. в культ. по столб.
                If Not cl_cc_v Is Nothing Then ' если поиск увенчался успехом
                    s_firstAddr$ = cl_cc_v.Address ' запоминаем адрес перв. найд. яч. чтобы не повторяться
                    Do
                        S_tmp! = S_inc + cl_cc_v.Offset(, -1).Value ' временная кумул. сумма
                        s_addr_tmp$ = cl_cc_v.Address ' теущий адр. найд. яч.
                        If S_tmp <= S And Not dic_addr.Exists(s_addr_tmp) Then ' _
                            если сумма НЕ больше заданной и этот адрес у нас ранее не был задействован
                            S_inc = S_tmp ' аккумулируем сумму
                            dic_addr(s_addr_tmp) = s_addr_tmp ' запоминаем в словарь адрес
                            Cells(cl_cc_v.Row, cl_cc.Column).Value = cl_cc_v.Offset(, -1).Value ' _
                                вносим в соотв. яч. площадь.
                        End If
                        Set cl_cc_v = rng_cur_cult_v.FindNext(cl_cc_v) ' поиск след. культ. в верт. перечне
                    Loop While s_firstAddr <> cl_cc_v.Address And S_inc < S ' продолжаем цикл, _
                        если адрес след яч. НЕ совп. с перв. и кумул. сумм. менее заданной
                End If
                Set cl_cult_w_rang = cl_cult_w_rang.Offset(1) ' след. яч. в рейт. предш. культ.
            Loop
        End If
    Next cl_cc
End Sub

Sub jjj()
    arr_clrs = Array(xlNone, 11851260, 15261367, 5540500, 13082801, xlNone) ' _
        массив номеров цветов для покраски согласно рейт. культ.
    Set rng_cur_cult_v = Range(Cells(10, 4), Cells(10, 4).End(xlDown)) ' культуры по столбцу
    Set rng_cur_cult_h = Range(Cells(6, 5), Cells(6, 4).End(xlToRight)) ' культуры в шапке
    dop = Cells(7, 11) + 1 ' погрешность
    With Range(Cells(11, 5), Cells(Cells(10, 4).End(xlDown).Row, Cells(6, 4).End(xlToRight).Column))
        .ClearContents ' очищаем стар. дан.
        .Interior.Pattern = xlNone ' убираем заливку
    End With '
    With Worksheets("Справочник"): Set rng_cur_w_prev = .Range(.Cells(9, 2), .Cells(Rows.Count, 2).End(xlUp)): End With ' _
        область поиска культуры из шапки в справочнике
    Set dic_addr = CreateObject("scripting.dictionary")
    For Each cl_cc In rng_cur_cult_h ' перебор культур в шапке
        S! = cl_cc.Offset(2).Value ' запомнили площадь
        S_inc! = 0 ' суммируемая площадь
        s_cc$ = cl_cc.Value ' запомнили текущую культуры
        Set cl_cc_dic = rng_cur_w_prev.Find(what:=s_cc, after:=rng_cur_w_prev(1), LookIn:=xlValues, _
            lookAt:=xlWhole, searchOrder:=xlByRows, searchDirection:=xlNext, MatchCase:=False, matchByte:=False) ' _
                ищем яч. с тек. культ. в справ.
        If Not cl_cc_dic Is Nothing Then ' если результат поиска не пустой
            Set cl_cult_w_rang = cl_cc_dic.Offset(1, 1) ' первая яч. в рейт. предш. культ.
            Do While Len(cl_cult_w_rang.Value) > 0 ' цикл, пока яч. в рейт. предш. культ. не пустая
                s_cc$ = cl_cult_w_rang.Value ' запомнили текущую культуры
                Set cl_cc_v = rng_cur_cult_v.Find(what:=s_cc, after:=rng_cur_cult_v(1), LookIn:=xlValues, _
                    lookAt:=xlWhole, searchOrder:=xlByRows, searchDirection:=xlNext, MatchCase:=False, matchByte:=False) ' _
                        ищем яч. с тек. культ. в культ. по столб.
                If Not cl_cc_v Is Nothing Then ' если поиск увенчался успехом
                    s_firstAddr$ = cl_cc_v.Address ' запоминаем адрес перв. найд. яч. чтобы не повторяться
                    Do
                        S_tmp! = S_inc + cl_cc_v.Offset(, -1).Value ' временная кумул. сумма
                        s_addr_tmp$ = cl_cc_v.Address ' теущий адр. найд. яч.
                        If S_tmp <= (S * dop) And Not dic_addr.Exists(s_addr_tmp) Then  ' _
                            если сумма НЕ больше заданной с погрешностью и этот адрес у нас ранее не был задействован
                            S_inc = S_tmp ' аккумулируем сумму
                            dic_addr(s_addr_tmp) = s_addr_tmp ' запоминаем в словарь адрес
                            Cells(cl_cc_v.Row, cl_cc.Column).Value = cl_cc_v.Offset(, -1).Value ' _
                                вносим в соотв. яч. площадь.
                            Cells(cl_cc_v.Row, cl_cc.Column).Interior.Color = _
                                arr_clrs(cl_cult_w_rang.Offset(, -1).Value) ' красим
                        End If
                        Set cl_cc_v = rng_cur_cult_v.FindNext(cl_cc_v) ' поиск след. культ. в верт. перечне
                    Loop While s_firstAddr <> cl_cc_v.Address And S_inc < S ' продолжаем цикл, _
                        если адрес след яч. НЕ совп. с перв. и кумул. сумм. менее заданной
                End If
                Set cl_cult_w_rang = cl_cult_w_rang.Offset(1) ' след. яч. в рейт. предш. культ.
            Loop
        End If
    Next cl_cc
End Sub