Наподобие задачи о рюкзаке

Option Explicit
 
Sub main()
    Dim a(), i&, j&, n&
    Dim n1&, n2&, s1&, s2&, dn&, ds&
    Dim out
    
    a = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 3) 'считываем с листа исходные данные
    n = UBound(a) 'кол-во предметов
    n1 = Val([f2]): n2 = Val([g2]) 'искомая длина
    s1 = Val([f3]): s2 = Val([g3]) 'искомая стоимость
    dn = Val([h2]): ds = Val([h3]) 'допустимая погрешность
    If dn = 0 Then dn = 1
    If ds = 0 Then ds = 1
    
    ReDim arr&(1 To n, 1 To 2)
    For i = 1 To n 'формируем массив для решения
        arr(i, 1) = Round(a(i, 2) / dn, 0) 'сокращаем значения на делители
        arr(i, 2) = Round(a(i, 3) / ds, 0)
    Next i
    
    With Range("L2")
        .Resize(1000, 4).ClearContents
        out = Rucksack(arr, Round(n1 / dn, 0), Round(n2 / dn, 0), Round(s1 / ds, 0), Round(s2 / ds, 0))
        If IsArray(out) Then 'если результат получен в виде масива, то выводим его на лист
            For i = UBound(out) To 1 Step -1
                .Offset(j, 0) = out(i)
                .Offset(j, 1) = a(out(i), 1)
                .Offset(j, 2) = a(out(i), 2)
                .Offset(j, 3) = a(out(i), 3)
                j = j + 1
            Next i
        End If
    End With
End Sub
 
Sub mainDynamic()
    Dim a(), i&, j&, n&
    Dim v&
    Dim out
    
    a = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 3) 'считываем с листа исходные данные
    n = UBound(a) 'кол-во предметов
    v = Val([f2]) 'искомый вес
    
    ReDim arr(1 To n, 1 To 2)
    For i = 1 To n 'формируем массив для решения
        arr(i, 1) = Round(a(i, 2), 0)
        arr(i, 2) = a(i, 3)
    Next i
    
    With Range("L2")
        .Resize(1000, 4).ClearContents
        out = RucksackDynamic(arr, v)
        If IsArray(out) Then 'если результат получен в виде масива, то выводим его на лист
            For i = 1 To UBound(out)
                .Offset(j, 0) = out(i)
                .Offset(j, 1) = a(out(i), 1)
                .Offset(j, 2) = a(out(i), 2)
                .Offset(j, 3) = a(out(i), 3)
                j = j + 1
            Next i
        End If
    End With
End Sub
 
Sub mainGreedy()
    Dim a(), i&, j&, n&
    Dim v&
    Dim out
    
    a = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 3) 'считываем с листа исходные данные
    n = UBound(a) 'кол-во предметов
    v = CDbl([f2]) 'искомая длина
    
    ReDim arr(1 To n, 1 To 2)
    For i = 1 To n 'формируем массив для решения
        arr(i, 1) = CDbl(a(i, 2))
        arr(i, 2) = CDbl(a(i, 3))
    Next i
    
    With Range("L2")
        .Resize(1000, 4).ClearContents
        out = RucksackGreedy(arr, v)
        If IsArray(out) Then 'если результат получен в виде масива, то выводим его на лист
            For i = 1 To UBound(out)
                .Offset(j, 0) = out(i)
                .Offset(j, 1) = a(out(i), 1)
                .Offset(j, 2) = a(out(i), 2)
                .Offset(j, 3) = a(out(i), 3)
                j = j + 1
            Next i
        End If
    End With
End Sub
 
Function Rucksack(arr&(), n1&, n2&, s1&, s2&)
'Функция решения "задачи о рюкзаке" с подбором по двум параметрам: длина и стоимость
'на входе:
'   arr() - двумерный массив, вес предметов и их стоимость
'   n1, n2 - необходимая длина предметов от n1 до n2
'   s1, s2 - необходимая стоимость предметов от s1 до s2
'на выходе одномерный массив индексов подобранных предметов
 
    Dim i&, j&, k&, k1&, k2&, n&, m&, x, out&()
    n = UBound(arr) 'кол-во исходных предметов
    
    ReDim oD(n2), a&(n2) 'массивы для динамического программирования
    For i = 0 To n2 'создаем массив словарей размерностью n2
        Set oD(i) = CreateObject("Scripting.Dictionary")
    Next i
    oD(0).Item(0) = 0& 'начальный элемент равен нулю
    a(0) = 1
    
    For i = 1 To n 'перебираем все предметы
        For j = n2 - arr(i, 1) To 0 Step -1 'проходим массив с конца до начала
            If a(j) Then 'если в текущее положение (длина шины - j) уже попадали
                For Each x In oD(j).Keys 'для каждого состояния (стоимости) данной длины добавляем предмет
                    k1 = j + arr(i, 1) 'новая длина рюкзака
                    k2 = Val(x) + arr(i, 2) 'новая стоимость
                    If k2 <= s2 Then 'если стоимость не превышает искомую
                        If Not oD(k1).Exists(k2) Then 'если данная стоимость для шины длиной k1 еще не было
                            a(k1) = a(k1) + 1 'увеличиваем кол-во различных стомостей для шины длиной k1
                            oD(k1).Item(k2) = i 'добавляем в словарь стоимость шины и номер предмета из которого мы в него попали
                            If k1 >= n1 And k2 >= s1 Then 'проверяем, попали ли в нужный допуск
                                While k1 'пока путь не закончится нулевым элементом
                                    m = oD(k1).Item(k2) 'теущий предмет
                                    k = k + 1 'прядковый номер в выходном массиве
                                    ReDim Preserve out&(1 To k) 'переопределяем выходной массив
                                    out(k) = m 'сохраняем элемент
                                    k1 = k1 - arr(m, 1) 'переходим в положение из какой длины сюда попали
                                    k2 = k2 - arr(m, 2) 'и какова предыдущая стоимость
                                Wend
                                Rucksack = out 'возвращаем полученный результат (набор индексов предметов)
                                Exit Function
                            End If
                        End If
                    End If
                Next x
            End If
    Next j, i
End Function
 
Function RucksackDynamic(arr(), v&)
'Функция решения "задачи о рюкзаке" с подбором наибольшей стоимости отрезков для шины длиной не болле v
'метод решения - динамическое программирование
'на входе:
'   arr() - двумерный массив, длина отрезков и их стоимость
'   v - наибольшая длина шин, которые могут быть отрезаны
'на выходе одномерный массив индексов подобранных предметов
    
    Dim i&, j&, k&, n&, s#, maxs#, m&, out&(), x
    n = UBound(arr) 'кол-во исходных предметов
    
    ReDim b#(v), p$(v)  'массивы для динамического программирования
 
    For i = 1 To n 'перебираем все отрезки
        For j = v - arr(i, 1) To 0 Step -1 'проходим массив с конца до начала
            If Len(p(j)) Or j = 0 Then  'если в текущее положение (длина шины - j) уже попадали, либо находимся в начальной точке
                k = j + arr(i, 1) 'новая длина шины
                s = b(j) + arr(i, 2) 'новая стоимость
                If b(k) < s Then  'если получаемая стоимость больше чем есть
                    b(k) = s 'запоминаем лучшую стоимость
                    p(k) = p(j) & " " & i 'запоминаем путь
                    If s > maxs Then maxs = s: m = k 'запоминаем максимум
                End If
            End If
    Next j, i
    'формируем путь
    k = 0
    For Each x In Split(Trim(p(m)))
        k = k + 1 'прядковый номер в выходном массиве
        ReDim Preserve out&(1 To k) 'переопределяем выходной массив
        out(k) = Val(x) 'сохраняем элемент
    Next x
    If k > 0 Then RucksackDynamic = out
End Function
 
Function RucksackGreedy(arr(), ByVal v)
'на входе:
'   arr() - двумерный массив, длина отрезка и их стоимость
'   v - наибольшую длину отрезка, который может умещатся в шину
'на выходе одномерный массив индексов подобранных предметов
    
    Dim i&, j&, k&, t&, n&, out&()
    n = UBound(arr) 'кол-во исходных предметов
    
    ReDim a&(1 To n), c#(1 To n) 'массивы для "жадного" алгоритма
    
    For i = 1 To n
        a(i) = i
        c(i) = arr(i, 2) / arr(i, 1) 'вычисляем удельную стоимость каждого предмета
        For j = 1 To i - 1 'сортируем индексы предметов
            If c(a(i)) > c(a(j)) Then t = a(j): a(j) = a(i): a(i) = t
    Next j, i
    
    For i = 1 To n
        If arr(a(i), 1) < v Then 'если предмет помещается в шину, то берем его
            k = k + 1
            ReDim Preserve out&(1 To k)
            out(k) = a(i)
            v = v - arr(a(i), 1)
            For j = 1 To k - 1 'сортируем выходной массив
                If out(k) < out(j) Then t = out(j): out(j) = out(k): out(k) = t
            Next j
        End If
    Next i
    If k > 0 Then RucksackGreedy = out
End Function