Подбор слагаемых.

[maksim_serg]

ну да, нашел ошибку. вот в этом варианте (и еще 800 похожих):
0
2
1
2
1
0
1
2
2
Он упорно дает ответ по сумме:
5,000000000000000088

Поменял тип данных суммы с Double на Currency и выдал 4411 вариантов

[Ammat]

Ваша версия- хорошая работа. Но мне нужен еще и макрос , так как мне неоходимо подгонять разные числа под разные суммы.Если сможете вставте во вложение.

[IgorGO]

поздравляю, коллега!
несмотря на разницу во времени в 4 часовых пояса, мы смогли на разных платформах получить одинаковый результат.
я ввел в свой алгоритм точность, и если разница между значениями не превышает точность - то значения считаются одинаковыми

в начале я накосячил с алгоритмом. рекурсия - удивительная вещь. когда пытаюсь в пошаговом режиме отловить ошибку то, силясь удержать в голове все данные, я на 3-ем, 4-ом рекурсивном входе процедуры в саму себя теряю сознание... и все приходится начинать сначала

а сейчас доволен алгоритмом, который на входе получает 2 параметра заданную сумму и произвольного размера диапазон ячеек с исходными числами, на выходе, справа от диапазона, выдает варианты количества чисел для получения заданной суммы.
и все это не полных 30 строк кода. правда, для принятых 9-ти значений время расчетов составило почти 10 сек.

а автор темы получил файл со всеми 4411 вариантами))

[maksim_serg]

мой цикл перебирает за 0.35 сек

[Ammat]

Здравствуйте. Кто может поделиться кодом для моей задачи.

[maksim_serg]

Вариант 1 (простой):
перебираете циклом все возможные варианты значений кол-ва каждой детали. Суммируете, сравниваете с заданной площадью, если равны - один из вариантов.

[Ammat]

Здравствуйте. Да , для специалиста этот вариант простой. Но не для меня.

[IgorGO]

Dim s0 As Double, k As Long, rg As Range, r As Double, e As Double

Sub Start()
  Dim c, s
  s0 = [a2]:  Set rg = [c2:c10]:  s = WorksheetFunction.Transpose(rg.Value)
  ReDim c(1 To UBound(s)): r = s(1): k = 1: e = 0.001 ^ 2: Calc s, c, UBound(s)
  MsgBox "см. левый нижний угол окна Ексел. там к-во вариантов":  Application.StatusBar = False
End Sub

Sub Calc(ByVal s, ByVal c, n)
  Dim i As Long, cr As Double
  c(n) = Int((s0 - SP(s, c)) / s(n) + e): cr = Round(s0 - SP(s, c), 3)
  If cr <= r Then r = cr: rg.Offset(0, k) = WorksheetFunction.Transpose(c)
  If cr ^ 2 < e Then k = k + 1: Application.StatusBar = k
  If n = 1 Then Exit Sub
  If c(n) = 0 Then
    Calc s, c, n - 1
  Else
    For i = 0 To c(n)
      If cr >= s(1) Then Calc s, c, n - 1
      If c(n) > 0 Then c(n) = c(n) - 1: cr = s0 - SP(s, c)
    Next
  End If
End Sub

Function SP(s, c) As Double
  Dim p As Double, i As Long
  For i = 1 To UBound(s):  p = p + s(i) * c(i):  Next
  SP = p
End Function

[Ammat]

Большое спасибо!!! То что надо.