Подбор слагаемых для нужной суммы

[bank_notes]

Доброго всем дня!
Прошу помощи в решении следующей задачи (поиск в сети удовлетворительного результата не дал). Девушка-секретарь клеит марки на конверты. Размер почтовых, номинал и набор марок может быть разным. Необходимо из имеющихся марок получить набор, дающий в результате необходимую (а при невозможности - ближайшую) сумму. В прилагаемом файле – попытка самостоятельно найти решение. Хотелось бы, при наборе, например, суммы 3,3 получить не "формальные" 2,5 + 0,7 = 3,2, а например 4 * 0,7 + 0,5 = 3,3. В идеале хотелось бы получить (все) варианты подбора, за исключением абсурдных (0,2 х 500 = 100) что можно было бы достичь ограничением использования марок мелкого номинала, например не более четырех. С благодарностью будут приняты любые подсказки (не говоря уже о готовом коде :-)). (Офис 2003).

[IgorGO]

вот так приблизительно:

Dim good As Single, goods As String
Const r As Long = 7

Sub Combine(v As Single, c As Long, s As String)
  Dim k As Long
  If c > 10 Then Exit Sub
  If v = 0 Then good = 0:  goods = s: Exit Sub
  If v < good Then good = v: goods = s
  If Cells(r, c) <= v Then
    k = Int(v / Cells(r, c)): Combine Round(v - k * Cells(r, c), 2), c + 1, s & " " & k
    If good = 0 Then Exit Sub
  End If
  Combine v, c + 1, s & " 0"
End Sub
  
  
Function Sum1(rg As Range) As String
  Dim s As String
  good = rg.Value
  Combine rg.Value, 1, ""
  s = "":  goods = Right(goods, Len(goods) - 1)
  For i = 0 To UBound(Split(goods))
    If Split(goods)(i) <> "0" Then s = s & " + " & Split(goods)(i) & "*" & Cells(r, i + 1)
  Next
  Sum1 = Right(s, Len(s) - 3)
End Function

см. вложение

[slan]

вот, делал для немножко другого, но работает. использование по возможности бОльших составляющих уже заложено в алгоритме.

в ячейку напротив сумма вводите нужную сумму и жмете "найти"

[IgorGO]

1. Исправил алгоритм (этот будет пребирать все возможные варианты до первого точного совпадения). Алгоритм можно назвать так: подбор марок необходимого номинала с минимальным количеством и (по возможности) с точным совпадением с ценой пересылки.
2. Оптимизировал код (сделал компактнее и понятнее)

Dim dV As Single
Const r As Long = 7


Function Combine(V As Single, c As Long, s As String) As String
  Dim k As Long, nv As Single
  For k = Int(V / Cells(r, c)) + 1 To 0 Step -1                          ' от макс.количества (с перебором на 1) до 0
    nv = Round(V - k * Cells(r, c), 2)                                   ' осталось оплатить, если наклеить эти К марок
    If nv = 0 Then dV = 0: Combine = s & " " & k:  Exit Function         ' НАШЛОСЬ ТОЧНОЕ РЕШЕНИЕ!!! Работа закончена
    If nv < 0 Then                                                       ' марок уже больше, чем стоимость пересылки
      If Abs(nv) < dV Then dV = Abs(nv): Combine = s & " " & k           ' пока это лучшее решение
    End If
    If c < 10 And dV <> 0 Then Combine = Combine(nv, c + 1, s & " " & k)
  Next
End Function
  
  
Function Sum1(rg As Range) As String
  Dim s As String, res As String
  dV = rg.Value
  res = Combine(rg.Value, 1, ""):  res = Right(res, Len(res) - 1):  s = ""
  For i = 0 To UBound(Split(res))
    If Split(res)(i) <> "0" Then s = s & " + " & IIf(Split(res)(i) = "1", "", Split(res)(i) & "*") & Cells(r, i + 1)
  Next
  Sum1 = Right(s, Len(s) - 3)
End Function