Набрать самые лучшие (ценные) в некий Рюкзак, с ограничением по полному весу

Наименование    Вес  Стоимость
Предмет 1        300 25800,20
Предмет 2        250 625,30
Предмет 3        156 4568,60
Предмет 4        168 9514,20
Предмет 5        314 15654,80
Предмет 6        215 92100,10
Предмет 7        841 654,20
Предмет 8        369 7520,50
Предмет 9        852 6352,40
Предмет 10       147 19558,77
Предмет 11       365 74580,50
Предмет 12       145 72806,00
Предмет 13       254 71031,50
Предмет 14       741 69257,00
Предмет 15       257 67482,50
Предмет 16       259 65708,00
Предмет 17       851 63933,50
Предмет 18       853 62159,00
Предмет 19       459 60384,50
Предмет 20       453 58610,00
Предмет 21       358 56835,50
Предмет 22       657 55061,00
Предмет 23       651 53286,50
Предмет 24       954 51512,00
Предмет 25       952 49737,50
Предмет 26       158 47963,00
Предмет 27       156 46188,50
Предмет 28       354 44414,00
Предмет 29       358 42639,50
Предмет 30       756 40865,00
Предмет 31       752 39090,50
Предмет 32       215 37316,00
Предмет 33       841 35541,50
Предмет 34       369 33767,00
Предмет 35       852 31992,50
Предмет 36       147 30218,00
Предмет 37       523 28443,50
Предмет 38       258 26669,00
Предмет 39       962 24894,50
Предмет 40       159 23120,00
Предмет 41       357 21345,50
Предмет 42       456 19571,00
Предмет 43       358 17796,50
Предмет 44       951 16022,00
Предмет 45       744 14247,50
Предмет 46       888 12473,00
Предмет 47       999 10698,50
Предмет 48       358 8924,00
Предмет 49       962 7149,50
Предмет 50       147 5375,00
Предмет 51       365 3600,50
Предмет 52       145 1826,00
Предмет 53       856 51,50
Предмет 54       965 35951,50
Предмет 55       854 1000,00
Предмет 56       745 1126,70
Предмет 57       856 1253,40
Предмет 58       963 1380,10
Предмет 59       256 1506,80
Предмет 60       365 1633,50
Предмет 61       145 1760,20
Предмет 62       254 1886,90
Предмет 63       741 2013,60
Предмет 64       257 2140,30
Предмет 65       259 2267,00
Предмет 66       851 2393,70
Предмет 67       853 2520,40
Предмет 68       459 2647,10
Предмет 69       453 2773,80
Предмет 70       358 2900,50
Предмет 71       657 3027,20
Предмет 72       651 3153,90
Предмет 73       954 3280,60
Предмет 74       952 3407,30
Предмет 75       158 3534,00
Предмет 76       156 3660,70
Предмет 77       354 3787,40
Предмет 78       358 3914,10
Предмет 79       756 4040,80
Предмет 80       752 4167,50
Предмет 81       300 4294,20
Предмет 82       250 4420,90
Предмет 83       156 4547,60
Предмет 84       168 4674,30
Предмет 85       314 4801,00
Предмет 86       215 4927,70
Предмет 87       841 5054,40
Предмет 88       369 5181,10
Предмет 89       852 5307,80
Предмет 90       147 5434,50
Предмет 91       523 5561,20
Предмет 92       258 5687,90
Предмет 93       962 5814,60
Предмет 94       159 5941,30
Предмет 95       357 6068,00
Предмет 96       456 6194,70
Предмет 97       358 6321,40
Предмет 98       951 6448,10
Предмет 99       744 6574,80

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
'на выходе одномерный массив индексов подобранных предметов
'Автор: Михаил Ч. (MCH), Август 2015
 
    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 - наибольший вес предметов, который может умещатся в рюкзак
'на выходе одномерный массив индексов подобранных предметов
'Автор: Михаил Ч. (MCH), Август 2015
    
    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)
'Функция решения "задачи о рюкзаке" с подбором наибольшей стоимости предметов для рюкзака весом не болле v
'метод решения - "жадный" алгоритм
'на входе:
'   arr() - двумерный массив, вес предметов и их стоимость
'   v - наибольший вес предметов, который может умещатся в рюкзак
'на выходе одномерный массив индексов подобранных предметов
'Автор: Михаил Ч. (MCH), Август 2015
    
    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

№ Наименование    Вес  Стоимость
1   Предмет 1        300 25800,2
4   Предмет 4        168 9514,2
5   Предмет 5        314 15654,8
6   Предмет 6        215 92100,1
10  Предмет 10       147 19558,76944
11  Предмет 11       365 74580,5
12  Предмет 12       145 72806
13  Предмет 13       254 71031,5
14  Предмет 14       741 69257
15  Предмет 15       257 67482,5
16  Предмет 16       259 65708
17  Предмет 17       851 63933,5
18  Предмет 18       853 62159
19  Предмет 19       459 60384,5
20  Предмет 20       453 58610
21  Предмет 21       358 56835,5
22  Предмет 22       657 55061
23  Предмет 23       651 53286,5
26  Предмет 26       158 47963
27  Предмет 27       156 46188,5
28  Предмет 28       354 44414
29  Предмет 29       358 42639,5
32  Предмет 32       215 37316
34  Предмет 34       369 33767
36  Предмет 36       147 30218
38  Предмет 38       258 26669
40  Предмет 40       159 23120
41  Предмет 41       357 21345,5

Option Explicit
 
'Казанский (09.03.2015, 23:22) События Excel можно обрабатывать в VB6, VBA собственно не нужен
'Создайте форму с кнопкой, в Project - References 
'подключите библиотеку Microsoft Excel xx.x Object Library 
'попробуйте такой код
 
 Dim WithEvents xlApp As Excel.Application
Dim xlWb As Excel.Workbook
 
Private Sub Command1_Click()
  Set xlApp = New Excel.Application
  Set xlWb = xlApp.Workbooks.Open("c:\temp\Лист1.xls") '==== путь к книге
  xlApp.Visible = True
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next
  xlApp.Quit
End Sub
 
Private Sub xlApp_WorkbookBeforeClose(ByVal wb As Excel.Workbook, Cancel As Boolean)
  If wb Is xlWb Then
    xlApp.Visible = False
    If MsgBox("VB6 - Вы уверены, что хотите закрыть книгу?", vbYesNo) = vbNo Then
      Cancel = True
      MsgBox "VB6 - ОК, продолжаем"
      xlApp.Visible = True
      Exit Sub
    Else
      xlApp.EnableEvents = False
      wb.Close True 'закрыть с сохранением
      xlApp.Quit
    End If
  End If
End Sub