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