combination of numbers

Harlan Grove wrote...
....
>Sub foo()
....
> For n = 2 To dv.Count
>
> For Each x In dv.Keys
>
> For Each y In dc.Keys
....

This looping logic doesn't work. If there are no matching combinations,
this will run a LONG, LONG, LONG time.

Harlan:
Nothing magical about 10 and 20, I just picked them from
typical posts last month.
My 10 columns on Sheet1 do not list temporary results, but valid
solutions to the posed problem.
The length of the list depends on the interval of the 20 numbers,
on the count of numbers chosen and on the sum.
I ran your numbers and got the same result as you,
plus 97 more combinations of 8 out of your 20 numbers that equal 3775.
Herb

"Herbert Seidenberg" <herbds7-msxls@yahoo.com> wrote in message
news:1125619841.075853.100910@z14g2000cwz.googlegroups.com...
>
> Harlan:
> Nothing magical about 10 and 20, I just picked them from
> typical posts last month.
> My 10 columns on Sheet1 do not list temporary results, but valid
> solutions to the posed problem.
> The length of the list depends on the interval of the 20 numbers,
> on the count of numbers chosen and on the sum.
> I ran your numbers and got the same result as you,
> plus 97 more combinations of 8 out of your 20 numbers that equal
> 3775.
> Herb
>

Could Harlan's code be modified to list all unique combinations rather
than just one?

I don't think there is a need to see each permutation, but certainly
unique combinations would be good.

Thanks,

Alan.

> plus 97 more combinations of 8 out of your 20 numbers that equal 3775.

Hi. Just gee wiz. Doesn't look like it, but I think there are 337
combinations that total 3775.
Ranging from

187, 449, 687, 692, 811, 949
to
97, 117, 187, 217, 248, 393, 443, 449, 507, 537, 580

--
Dana DeLouis
Win XP & Office 2003


"Herbert Seidenberg" <herbds7-msxls@yahoo.com> wrote in message
news:1125619841.075853.100910@z14g2000cwz.googlegroups.com...
> Harlan:
> Nothing magical about 10 and 20, I just picked them from
> typical posts last month.
> My 10 columns on Sheet1 do not list temporary results, but valid
> solutions to the posed problem.
> The length of the list depends on the interval of the 20 numbers,
> on the count of numbers chosen and on the sum.
> I ran your numbers and got the same result as you,
> plus 97 more combinations of 8 out of your 20 numbers that equal 3775.
> Herb
>

Dana:
Your first example has 6 numbers, the second 11.
Harlan and my criteria were 8 numbers.
Herb

"Dana DeLouis" <delouis@bellsouth.net> wrote in message
news:uN5IgJ2rFHA.4040@TK2MSFTNGP14.phx.gbl...
>
> Hi. Just gee wiz. Doesn't look like it, but I think there are 337
> combinations that total 3775.
> Ranging from
>
> 187, 449, 687, 692, 811, 949
> to
> 97, 117, 187, 217, 248, 393, 443, 449, 507, 537, 580
>

Hi Dana,

That is amazing - how did you get all 337 answers?

The specific discussion above was restricted to only sets of a
particular size, but in the real world sets of *all* size would
normally be required.

Did you use code like Harlan's? If so, could you post it back here?

Thanks,

Alan.

Dana DeLouis wrote...
....
>Hi. Just gee wiz. Doesn't look like it, but I think there are 337
>combinations that total 3775.
>Ranging from
>
>187, 449, 687, 692, 811, 949
>to
>97, 117, 187, 217, 248, 393, 443, 449, 507, 537, 580
....

I get the following as the final combination (smallest initial number,
vs your smallest final number).

+537+507+506+506+449+393+309+217+187+117+47

I also get only 247 combinations that sum to 3775, so our respective
sets of combinations differ in cardinality by a suspiciously round 90.
Here are my 247.

+949+811+692+687+449+187
+949+811+765+580+506+117+47
+949+811+765+537+449+217+47
+949+811+765+537+309+217+187
+949+811+765+506+449+248+47
+949+811+765+506+309+248+187
+949+811+687+537+507+187+97
+949+811+537+507+506+248+217
+949+811+507+506+506+449+47
+949+811+507+506+506+309+187
+949+765+692+507+506+309+47
+949+765+687+580+449+248+97
+949+765+580+506+449+309+217
+949+692+687+537+506+217+187
+949+692+687+506+506+248+187
+949+692+580+537+507+393+117
+949+692+537+507+449+393+248
+949+687+580+507+506+449+97
+949+687+580+506+443+393+217
+949+580+537+506+506+449+248
+811+765+692+687+506+217+97
+811+765+692+507+443+309+248
+811+765+687+580+506+309+117
+811+765+687+537+449+309+217
+811+765+687+506+449+309+248
+811+692+687+506+449+443+187
+811+687+507+506+506+449+309
+765+692+580+537+449+443+309
+949+811+765+580+309+217+97+47
+949+811+765+506+393+187+117+47
+949+811+692+449+443+217+117+97
+949+811+687+537+309+248+187+47
+949+811+687+507+309+248+217+47
+949+811+580+537+506+248+97+47
+949+811+580+449+443+309+187+47
+949+811+580+449+393+309+187+97
+949+811+537+506+449+309+117+97
+949+765+687+580+443+187+117+47
+949+765+687+580+393+187+117+97
+949+765+687+537+506+187+97+47
+949+765+687+507+506+217+97+47
+949+765+687+449+443+248+187+47
+949+765+687+449+393+248+187+97
+949+765+580+537+443+217+187+97
+949+765+580+506+443+248+187+97
+949+765+580+506+393+248+217+117
+949+765+537+506+506+248+217+47
+949+765+506+449+393+309+217+187
+949+692+687+580+506+217+97+47
+949+692+580+507+443+309+248+47
+949+692+580+507+393+309+248+97
+949+687+580+537+449+309+217+47
+949+687+580+506+449+309+248+47
+949+687+537+507+443+248+217+187
+949+687+507+506+449+443+187+47
+949+687+507+506+449+393+187+97
+949+580+537+506+506+393+187+117
+949+580+507+506+506+443+187+97
+949+580+507+506+506+393+217+117
+949+537+506+506+449+393+248+187
+949+507+506+506+449+393+248+217
+811+765+692+537+449+217+187+117
+811+765+692+507+443+393+117+47
+811+765+692+506+449+248+187+117
+811+765+687+537+443+248+187+97
+811+765+687+537+393+248+217+117
+811+765+687+507+443+248+217+97
+811+765+687+506+449+393+117+47
+811+765+687+506+393+309+187+117
+811+765+580+506+506+443+117+47
+811+765+580+506+506+393+117+97
+811+765+580+449+443+393+217+117
+811+765+537+506+449+443+217+47
+811+765+537+506+449+393+217+97
+811+765+537+506+443+309+217+187
+811+765+506+506+449+443+248+47
+811+765+506+506+449+393+248+97
+811+765+506+506+443+309+248+187
+811+692+687+580+443+248+217+97
+811+692+687+506+506+309+217+47
+811+692+507+506+506+449+187+117
+811+687+580+537+506+309+248+97
+811+687+537+507+506+443+187+97
+811+687+537+507+506+393+217+117
+811+687+507+506+506+393+248+117
+811+537+507+506+506+443+248+217
+765+692+687+537+507+443+97+47
+765+692+580+537+443+393+248+117
+765+692+537+449+443+393+309+187
+765+692+507+506+506+443+309+47
+765+692+507+506+506+393+309+97
+765+692+507+449+443+393+309+217
+765+687+580+537+449+443+217+97
+765+687+580+506+449+443+248+97
+765+687+537+506+506+309+248+217
+765+580+506+506+449+443+309+217
+692+687+537+506+506+443+217+187
+692+580+537+507+506+443+393+117
+692+537+507+506+449+443+393+248
+687+580+537+506+506+449+393+117
+687+580+507+506+506+449+443+97
+949+811+765+393+309+217+187+97+47
+949+811+692+507+248+217+187+117+47
+949+811+580+443+393+248+187+117+47
+949+811+537+506+393+248+187+97+47
+949+811+507+506+393+248+217+97+47
+949+765+537+507+449+217+187+117+47
+949+765+507+506+449+248+187+117+47
+949+692+687+506+393+217+187+97+47
+949+692+580+537+449+217+187+117+47
+949+692+580+506+449+248+187+117+47
+949+692+507+443+393+309+248+187+47
+949+692+506+506+443+248+217+117+97
+949+687+580+537+443+248+187+97+47
+949+687+580+537+393+248+217+117+47
+949+687+580+507+443+248+217+97+47
+949+687+580+506+393+309+187+117+47
+949+687+537+449+443+309+187+117+97
+949+687+537+449+393+309+217+187+47
+949+687+507+449+443+309+217+117+97
+949+687+506+449+393+309+248+187+47
+949+580+537+506+449+393+217+97+47
+949+580+537+506+443+309+217+187+47
+949+580+537+506+393+309+217+187+97
+949+580+506+506+449+393+248+97+47
+949+580+506+506+443+309+248+187+47
+949+580+506+506+393+309+248+187+97
+949+580+449+443+393+309+248+217+187
+949+537+506+449+443+309+248+217+117
+811+765+692+580+449+217+117+97+47
+811+765+692+580+309+217+187+117+97
+811+765+692+449+309+248+217+187+97
+811+765+687+449+393+309+217+97+47
+811+765+580+506+443+309+217+97+47
+811+765+537+507+506+248+187+117+97
+811+765+506+506+443+393+187+117+47
+811+692+687+537+449+248+187+117+47
+811+692+687+507+449+248+217+117+47
+811+692+687+507+309+248+217+187+117
+811+692+687+443+393+248+217+187+97
+811+692+580+537+506+248+187+117+97
+811+692+580+507+506+248+217+117+97
+811+692+537+507+443+393+248+97+47
+811+692+507+506+449+309+217+187+97
+811+687+580+537+506+393+117+97+47
+811+687+580+449+443+393+248+117+47
+811+687+580+443+393+309+248+187+117
+811+687+537+506+449+393+248+97+47
+811+687+537+506+443+309+248+187+47
+811+687+537+506+393+309+248+187+97
+811+687+507+506+443+309+248+217+47
+811+687+507+506+393+309+248+217+97
+811+580+537+507+449+309+248+217+117
+811+580+537+506+506+443+248+97+47
+811+580+537+449+443+393+248+217+97
+811+580+506+449+443+393+309+187+97
+811+537+506+506+449+443+309+117+97
+811+537+506+506+449+393+309+217+47
+765+692+687+537+393+309+248+97+47
+765+692+687+507+506+217+187+117+97
+765+692+580+449+443+393+309+97+47
+765+692+537+506+506+248+217+187+117
+765+687+580+537+507+248+217+187+47
+765+687+580+506+443+393+187+117+97
+765+687+537+507+449+309+217+187+117
+765+687+537+506+506+443+187+97+47
+765+687+537+506+506+393+217+117+47
+765+687+537+449+443+393+217+187+97
+765+687+507+506+506+443+217+97+47
+765+687+507+506+449+309+248+187+117
+765+687+506+449+443+393+248+187+97
+765+580+537+507+506+449+217+117+97
+765+580+507+506+506+449+248+117+97
+765+580+506+506+443+393+248+217+117
+765+506+506+449+443+393+309+217+187
+692+687+580+537+449+309+217+187+117
+692+687+580+507+443+393+309+117+47
+692+687+580+506+506+443+217+97+47
+692+687+580+506+449+309+248+187+117
+692+687+537+507+506+393+309+97+47
+692+687+507+449+443+393+309+248+47
+692+580+537+507+443+393+309+217+97
+692+580+507+506+443+393+309+248+97
+687+580+537+506+449+443+309+217+47
+687+580+537+506+449+393+309+217+97
+687+580+506+506+449+443+309+248+47
+687+580+506+506+449+393+309+248+97
+687+507+506+506+449+443+393+187+97
+949+811+537+443+309+248+217+117+97+47
+949+765+580+507+309+217+187+117+97+47
+949+765+507+449+309+248+217+187+97+47
+949+692+580+449+309+248+217+187+97+47
+949+687+507+443+393+248+217+187+97+47
+949+580+537+507+506+248+187+117+97+47
+811+765+692+449+393+217+187+117+97+47
+811+765+687+507+309+248+187+117+97+47
+811+765+506+443+393+309+217+187+97+47
+811+692+687+580+309+248+187+117+97+47
+811+692+507+506+443+248+217+187+117+47
+811+692+507+506+393+248+217+187+117+97
+811+687+506+506+449+248+217+187+117+47
+811+580+537+507+449+443+187+117+97+47
+811+537+507+506+506+309+248+187+117+47
+811+537+507+449+393+309+248+217+187+117
+811+537+506+506+443+393+248+187+97+47
+811+507+506+506+443+393+248+217+97+47
+765+692+687+506+309+248+217+187+117+47
+765+692+580+506+506+248+217+117+97+47
+765+692+506+506+449+309+217+187+97+47
+765+687+580+537+449+309+187+117+97+47
+765+687+580+507+449+309+217+117+97+47
+765+687+506+506+393+309+248+217+97+47
+765+580+537+506+449+309+248+217+117+47
+765+537+507+506+449+443+217+187+117+47
+765+537+507+506+449+393+217+187+117+97
+765+507+506+506+449+443+248+187+117+47
+765+507+506+506+449+393+248+187+117+97
+692+687+580+507+443+248+217+187+117+97
+692+687+507+506+506+309+217+187+117+47
+692+687+506+506+443+393+217+187+97+47
+692+580+537+506+449+443+217+187+117+47
+692+580+537+506+449+393+217+187+117+97
+692+580+506+506+449+443+248+187+117+47
+692+580+506+506+449+393+248+187+117+97
+687+580+537+507+506+449+248+117+97+47
+687+580+537+507+506+309+248+187+117+97
+687+580+537+506+443+393+248+217+117+47
+687+580+506+506+443+393+309+187+117+47
+687+537+506+449+443+393+309+217+187+47
+687+506+506+449+443+393+309+248+187+47
+580+537+507+506+506+449+309+217+117+47
+580+537+506+506+449+443+393+217+97+47
+580+537+506+506+443+393+309+217+187+97
+949+506+449+443+393+309+248+217+117+97+47
+811+580+537+449+393+309+248+187+117+97+47
+811+580+507+449+393+309+248+217+117+97+47
+765+692+506+506+393+248+217+187+117+97+47
+765+687+507+449+393+309+217+187+117+97+47
+765+580+507+506+443+309+217+187+117+97+47
+765+537+506+449+393+309+248+217+187+117+47
+765+507+506+449+443+309+248+217+187+97+47
+692+687+580+449+393+309+217+187+117+97+47
+692+580+506+449+443+309+248+217+187+97+47
+687+537+507+506+449+393+248+187+117+97+47
+580+537+507+506+506+443+248+187+117+97+47
+580+537+507+449+443+393+248+217+187+117+97
+537+507+506+506+449+393+309+217+187+117+47

Presumably you calculated yours in Mathematica. Would you be willing to
share your code and your full set of combinations?

Thanks. I really like your code. I see where I went wrong. I was
treating 506 on one line as different than the 506 on another line. With
that in mind, I too get 247 unique solutions. Thanks for the catch. :>)
Actually, I was just trying to point out how surprising the total number of
combinations can be. I would have guessed maybe 2 or 3.
Just for fun, the totals that have the most combinations are 4265 and 4782.
Your program caught all 314 combinations. :>) I would have guessed 2,
maybe 3 at the most. Again, I just find it interesting that there are that
many. :>)

--
Dana DeLouis
Win XP & Office 2003


<....>
> I also get only 247 combinations that sum to 3775, so our respective
> sets of combinations differ in cardinality by a suspiciously round 90.
> Here are my 247.
>
> +949+811+692+687+449+187
> +949+811+765+580+506+117+47
> +949+811+765+537+449+217+47
etc...

<snip>

Hi

I have a similar problem as mentioned above.

Say I have 10 numbers, and some will be duplicated.

eg 1,2,2,5,5,7,8,9,10,12

How can I produce a list of combinations of say 5 numbers that add up to say
30.

I want my list to include ALL combinations

ie 1 2 8 9 10 will appear twice as it will use a different number 2.

I think I need Dana's macro mentioned previously but please enlighten me.

Hope my ramblings make sense - Many thanks.

Mike

"Dana DeLouis" wrote:

> Thanks. I really like your code. I see where I went wrong. I was
> treating 506 on one line as different than the 506 on another line. With
> that in mind, I too get 247 unique solutions. Thanks for the catch. :>)
> Actually, I was just trying to point out how surprising the total number of
> combinations can be. I would have guessed maybe 2 or 3.
> Just for fun, the totals that have the most combinations are 4265 and 4782.
> Your program caught all 314 combinations. :>) I would have guessed 2,
> maybe 3 at the most. Again, I just find it interesting that there are that
> many. :>)
>
> --
> Dana DeLouis
> Win XP & Office 2003
>
>
> <....>
> > I also get only 247 combinations that sum to 3775, so our respective
> > sets of combinations differ in cardinality by a suspiciously round 90.
> > Here are my 247.
> >
> > +949+811+692+687+449+187
> > +949+811+765+580+506+117+47
> > +949+811+765+537+449+217+47
> etc...
>
> <snip>
>
>
>

Mike__ wrote...
....
>Say I have 10 numbers, and some will be duplicated.
>
>eg 1,2,2,5,5,7,8,9,10,12
>
>How can I produce a list of combinations of say 5 numbers that add up to say
>30.
>
>I want my list to include ALL combinations
>
>ie 1 2 8 9 10 will appear twice as it will use a different number 2.
>
>I think I need Dana's macro mentioned previously but please enlighten me.
....

Dana never provided the code he used to produce his results. I
speculated that he used Mathematica to generate all nonempty
combinations, then summed each of them. If so, that's a relatively
simple operation in Mathematica because it includes built-in means to
generate combinations and sum the combinations. It's not as easy in
Excel.

Worst case, this class of problem requires checking all 2^N
combinations. It's a practical necessity to eliminate unnecessary
branches and reduce unnecessary duplication from the iterative process.
That's why my macro doesn't produce multiple identical combinations
when there are duplicate numbers in the original set. Doing so requires
additional overhead that grows with the number of combinations in each
iterative step.

If you took the output from my macro, you have the distinct
combinations that sum to the target value. Use Data > Text to Columns
to split those into separate columns. If your original set were in
J5:J14 and the parsed (Data > Text to Columns) distinct combinations
were in L5:Q24, you could calculate the number of instances in K5:K24
using the following formulas.

K5 [array formula]:
=PRODUCT(IF(COUNTIF($J$5:$J$14,L5:Q5),
COUNTIF($J$5:$J$14,L5:Q5)/COUNTIF(L5:Q5,L5:Q5)))

Select K5 and fill down into K6:K24.

The distinct combinations of your original data that sum to 30 are

12 10 8
10 8 7 5
12 10 7 1
12 9 8 1
12 9 7 2
12 8 5 5
9 8 7 5 1
10 9 8 2 1
10 9 7 2 2
10 9 5 5 1
10 8 5 5 2
12 10 5 2 1
12 9 5 2 2
12 8 7 2 1
12 7 5 5 1
9 8 5 5 2 1
9 7 5 5 2 2
10 8 7 2 2 1
10 7 5 5 2 1
12 8 5 2 2 1

and the number of instances of each using the col K formulas above are

1
2
1
1
2
1
2
2
1
1
2
4
2
2
1
2
1
1
2
2

Macros are the only way to generate the necessary combinations with
some efficiency. Formulas are more efficient counting the instances of
each of the distinct combinations in the solution set.

Fixed the code. It's a bit more involved now. It should now list all
solutions in a new worksheet. (See my follow-up to Dana DeLouis in
another branch as to whether it misses some solutions).


'---- begin VBA code ----
Option Explicit


Sub foo()
Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp

On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

re.Global = True
re.IgnoreCase = True

t = Range("A23").Value2

Set dco = dc1
Set dcn = dc2

Call recsoln

For Each x In Range("A1:A20").Value2
If VarType(x) = vbDouble Then
If x = t Then
recsoln "+" & Format(x)

ElseIf dco.Exists(x) Then
dco(x) = dco(x) + 1

ElseIf x < t Then
dco.Add Key:=x, Item:=1
Application.StatusBar = dco.Count

End If

End If
Next x

n = dco.Count

ReDim v(1 To n, 1 To 2)

For k = 1 To n
v(k, 1) = dco.Keys(k - 1)
v(k, 2) = dco.Items(k - 1)
Next k

qsortd v, 1, n

For k = 1 To n
dcn.Add Key:="+" & Format(v(k, 1)), Item:=v(k, 1)
Next k

For k = 2 To n
dco.RemoveAll
swapo dco, dcn

For Each y In dco.Keys
p = False

For j = 1 To n
x = v(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True

If p Then
re.Pattern = "\" & s & "(?=(\+|$))"

If re.Execute(y).Count < v(j, 2) Then
u = dco(y) + x

If u = t Then
recsoln y & s

ElseIf u < t Then
dcn.Add Key:=y & s, Item:=u
Application.StatusBar = dcn.Count

End If

End If

End If

Next j

Next y

Next k

If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"

CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False

End Sub


Private Function recsoln(Optional s As String)
Static n As Long, ws As Worksheet, r As Range

If s = "" Then
recsoln = n

If n = 0 And r Is Nothing Then
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
ws.Activate

Else
n = 0

End If

Else
r.Offset(n, 0).Value = s
n = n + 1
recsoln = n

End If

End Function


Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim j As Long, pvt As Long

If (lft >= rgt) Then Exit Sub

swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)

pvt = lft

For j = lft + 1 To rgt
If v(j, 1) > v(lft, 1) Then
pvt = pvt + 1
swap2 v, pvt, j
End If
Next j

swap2 v, lft, pvt

qsortd v, lft, pvt - 1
qsortd v, pvt + 1, rgt

End Sub


Private Sub swap2(v As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim t As Variant

t = v(i, 1)
v(i, 1) = v(j, 1)
v(j, 1) = t

t = v(i, 2)
v(i, 2) = v(j, 2)
v(j, 2) = t

End Sub


Private Sub swapo(a As Object, b As Object)
Dim t As Object

Set t = a
Set a = b
Set b = t

End Sub
'---- end VBA code ----

Harlan,

Below is a problem statement from years ago, and the code that solves it
relatively quickly - a few seconds. I tried your code to solve it, but my
machine locked up after a couple of minutes.

Perhaps there is something in Michel's code that might be of use in the
current application.

Bernie


'I was asked by a colleague to find the combination of certain numbers
'which will add up to a specific value. The numbers I was given were:
'
' 52.04;57.63;247.81;285.71;425.00;690.72;764.57;1485.00;1609.24;
' 3737.45;6485.47;6883.85;7309.33;12914.64;13714.11;14346.39;
' 15337.85;22837.83;31201.42;34663.07;321987.28
'
' (21 numbers in ascending order)
'
' I am trying to get a combination so that it adds up to 420422.19.
'
' On a sheet, put the following
' B1 Target 420422.19
' B2 number of parameters 21
' B3:B23 all parameters in descending order
' 321987.28
' 34663.07
' 31201.42
' 22837.83
' 15337.85
' 14346.39
' 13714.11
' 12914.64
' 7309.33
' 6883.85
' 6485.47
' 3737.45
' 1609.24
' 1485
' 764.57
' 690.72
' 425
' 285.71
' 247.81
' 57.63
' 52.04
' Start find_sol, it will put "1" or "0" in C3:Cx if you sum the
' parameters with a "1", you will have the best solution.
' It takes about 12 seconds on my very slow P133.
' The solution is
' 1 1 0 1 0 0 1 1 1 0 0 1 1 0 0 1 1 1 1 0 0
' Regards.
'
' Michel.
' Michel Claes <michel.claes@CREDITCOMMUNAL.BE>


Option Explicit

Global target As Double
Global nbr_elem As Integer
Global stat(30) As Integer
Global statb(30) As Integer
Global elems(30) As Double
Global best As Double

Sub store_sol()
Dim i As Integer
For i = 1 To nbr_elem
Cells(i + 2, 3) = statb(i)
Next i
End Sub

Sub copy_stat()
Dim i As Integer
For i = 1 To nbr_elem
statb(i) = stat(i)
Next i
End Sub

Sub eval(ByVal total As Double, ByVal pos As Integer)
If pos <= nbr_elem Then
stat(pos) = 0
eval total, pos + 1
stat(pos) = 1
eval total + elems(pos), pos + 1
Else
If (Abs(total - target) < Abs(target - best)) Then
best = total
copy_stat
End If
End If
End Sub

Sub find_sol()
Dim i As Integer
best = 0
target = Cells(1, 2)
nbr_elem = Cells(2, 2)
For i = 1 To nbr_elem
elems(i) = Cells(i + 2, 2)
Next i
eval 0, 1
store_sol
End Sub


"Harlan Grove" <hrlngrv@aol.com> wrote in message
news:1125640838.220134.309410@z14g2000cwz.googlegroups.com...
> Fixed the code.

Bernie Deitrick wrote...
>Below is a problem statement from years ago, and the code that solves it
>relatively quickly - a few seconds. I tried your code to solve it, but my
>machine locked up after a couple of minutes.
....
>' I am trying to get a combination so that it adds up to 420422.19.
>'
>' On a sheet, put the following
>' B1 Target 420422.19
>' B2 number of parameters 21
>' B3:B23 all parameters in descending order
>' 321987.28
>' 34663.07
>' 31201.42
>' 22837.83
>' 15337.85
>' 14346.39
>' 13714.11
>' 12914.64
>' 7309.33
>' 6883.85
>' 6485.47
>' 3737.45
>' 1609.24
>' 1485
>' 764.57
>' 690.72
>' 425
>' 285.71
>' 247.81
>' 57.63
>' 52.04
....

Problem with my code (1st revision) is using exact equality, killer for
fractional decimal values. It exhausted your data set without finding
any combination that summed to your target value. It took a few minutes
to do so on my machine.

I've modified it a bit in the last day and a half, in part to deal with
this. I'm sure you'll be thrilled to know it now finds the solution to
the problem above in a fraction of a second.

+321987.28+34663.07+22837.83+13714.11+12914.64+7309.33+3737.45+1609.24
+690.72+425+285.71+247.81

The macros you provided produce the single closest combination. Useful,
but not exactly the same as finding exact combinations (as rounded
decimals). Also, my revised code, in the absence of rounding error,
e.g., when all values are integers of 15 or fewer decimal digits,
produces all combinations summing to the target value. Modifying the
macros you provided to do the same would be a challenge.

And here's the revised code. It even has a user interface now!


'---- begin VBA code ----
Option Explicit


Sub findsums()
Const TOL As Double = 0.000001 'modify as needed
Dim c As Variant

Dim j As Long, k As Long, n As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim v As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp

re.Global = True
re.IgnoreCase = True

On Error Resume Next

Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)

If x Is Nothing Then
Err.Clear
Exit Sub
End If

y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If

On Error GoTo 0

Set dco = dc1
Set dcn = dc2

Call recsoln

For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < TOL Then
recsoln "+" & Format(y)

ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1

ElseIf y < t - TOL Then
dco.Add Key:=y, Item:=1

c = CDec(c + 1)
Application.StatusBar = "[1] " & Format(c)

End If

End If
Next y

n = dco.Count

ReDim v(1 To n, 1 To 3)

For k = 1 To n
v(k, 1) = dco.Keys(k - 1)
v(k, 2) = dco.Items(k - 1)
Next k

qsortd v, 1, n

For k = n To 1 Step -1
v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
If v(k, 3) > t Then dcn.Add Key:="+" & Format(v(k, 1)), Item:=v(k,
1)
Next k

On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

For k = 2 To n
dco.RemoveAll
swapo dco, dcn

For Each y In dco.Keys
p = False

For j = 1 To n
If v(j, 3) < t - dco(y) - TOL Then Exit For

x = v(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True

If p Then
re.Pattern = "\" & s & "(?=(\+|$))"
If re.Execute(y).Count < v(j, 2) Then
u = dco(y) + x

If Abs(t - u) < TOL Then
recsoln y & s

ElseIf u < t - TOL Then
dcn.Add Key:=y & s, Item:=u

c = CDec(c + 1)
Application.StatusBar = "[" & Format(k) & "] " &
Format(c)

End If
End If
End If
Next j
Next y

If dcn.Count = 0 Then Exit For
Next k

If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"

CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False

End Sub


Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste

Static r As Range
Dim ws As Worksheet

If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)

If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False

Else
ws.Cells.Clear
Set r = ws.Range("A1")

End If

recsoln = 0

ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing

Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1

End If

End Function


Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim j As Long, pvt As Long

If (lft >= rgt) Then Exit Sub

swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)

pvt = lft

For j = lft + 1 To rgt
If v(j, 1) > v(lft, 1) Then
pvt = pvt + 1
swap2 v, pvt, j
End If
Next j

swap2 v, lft, pvt

qsortd v, lft, pvt - 1
qsortd v, pvt + 1, rgt
End Sub


Private Sub swap2(v As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161

Dim t As Variant, k As Long

For k = LBound(v, 2) To UBound(v, 2)
t = v(i, k)
v(i, k) = v(j, k)
v(j, k) = t
Next k
End Sub


Private Sub swapo(a As Object, b As Object)
Dim t As Object

Set t = a
Set a = b
Set b = t
End Sub
'---- end VBA code ----

Hi. This doesn't apply here, so it's just for discussion..
In some optimization programs, it can sometimes be a good technique to
re-scale the problem. For financial data in some programs, one option would
be to multiply all data by 100 to make the numbers integers (working with
whole pennies). This doesn't work too well though with a spreadsheet and
Solver. However, there are some Solver problems that can benefit by working
with whole pennies.
So, another option in some programs might be to find a combination from
5204, 5763, 24781, 28571, 42500, ..etc

that sum to 42,042,219

--
Dana DeLouis
Win XP & Office 2003


> 'I was asked by a colleague to find the combination of certain numbers
> 'which will add up to a specific value. The numbers I was given were:
> '
> ' 52.04;57.63;247.81;285.71;425.00;690.72;764.57;1485.00;1609.24;
> ' 3737.45;6485.47;6883.85;7309.33;12914.64;13714.11;14346.39;
> ' 15337.85;22837.83;31201.42;34663.07;321987.28
> '
> ' (21 numbers in ascending order)
> '
> ' I am trying to get a combination so that it adds up to 420422.19.
> '
<<snip>>

"Dana DeLouis" wrote...
>Hi. This doesn't apply here, so it's just for discussion..
>In some optimization programs, it can sometimes be a good technique
>to re-scale the problem. For financial data in some programs, one
>option would be to multiply all data by 100 to make the numbers
>integers (working with whole pennies). This doesn't work too well
>though with a spreadsheet and Solver. However, there are some Solver
>problems that can benefit by working with whole pennies. So, another
>option in some programs might be to find a combination from 5204,
>5763, 24781, 28571, 42500, ..etc that sum to 42,042,219
....

I was think about that. It'd be possible to promt for users inputs of
scaling values and rounding tolerance. Setting the former to 100 and the
latter to 0 would scale monetary amounts to integers and only accept exact
equality. But it'd also allow for other sorts of problems.