--
ErnestoMarti
------------------------------------------------------------------------
ErnestoMarti's Profile: http://www.excelforum.com/member.php?action=getinfo&userid=26836
View this thread: http://www.excelforum.com/showthread.php?threadid=400817
--
Regards,
Peo Sjoblom
(No private emails please)
"ErnestoMarti" <ErnestoMarti.1umz...@excelforum-nospam.com>
wrote in message
news:ErnestoMarti.1umz...@excelforum-nospam.com...
If Peo's Solver solution doesn't work (it usually won't with that many numbers), send me an email
(reply to this post, and take out the spaces and change the dot to . ), and I will send you a
workbook with a macro that can handle cases that Solver won't.
HTH,
Bernie
MS Excel MVP
"ErnestoMarti" <ErnestoMarti.1umz...@excelforum-nospam.com> wrote in message
news:ErnestoMarti.1umz...@excelforum-nospam.com...
>
Option Explicit
Option Base 1
Sub sum_perm()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
Dim p As Long
Dim q As Integer
Dim r As Integer
Dim s As Integer
Dim t As Integer
Dim u As Integer
Dim v As Integer
Dim NN As Integer
Dim SS As Integer
Dim ix As Integer
Dim jx As Integer
Dim kx As Integer
Dim mx As Integer
Dim nx As Integer
Dim rx As Integer
Dim sx As Integer
Dim tx As Integer
Dim ux As Integer
Dim vx As Integer
Dim ns As Integer
Dim binx() As Variant
Dim accum() As Variant
Range("Results").ClearContents
NN = Range("Numbers")
p = Range("CombTot")
ns = Range("Num_Sel")
ReDim accum(p, ns)
ReDim binx(NN)
SS = Range("Total")
ReDim binx(NN)
For p = 1 To NN
binx(p) = Range("Bin1").Cells(p, 1)
Next p
p = 1
For i = 1 To NN
For j = i + 1 To NN
For k = j + 1 To NN
For m = k + 1 To NN
For n = m + 1 To NN
For r = n + 1 To NN
For s = r + 1 To NN
For t = s + 1 To NN
For u = t + 1 To NN
For v = u + 1 To NN
ix = binx(i)
jx = binx(j)
kx = binx(k)
mx = binx(m)
nx = binx(n)
rx = binx(r)
sx = binx(s)
tx = binx(t)
ux = binx(u)
vx = binx(v)
If (ix + jx + kx + mx + nx + rx + sx + tx + ux + vx) = SS Then
accum(p, 1) = ix
accum(p, 2) = jx
accum(p, 3) = kx
accum(p, 4) = mx
accum(p, 5) = nx
accum(p, 6) = rx
accum(p, 7) = sx
accum(p, 8) = tx
accum(p, 9) = ux
accum(p, 10) = vx
p = p + 1
End If
Next v
Next u
Next t
Next s
Next r
Next n
Next m
Next k
Next j
Next i
Range("Pcount") = p 'count of valid answers
Range("Results") = accum
End Sub
What's magic about 10 out of 20 numbers?
>The first 10 columns of your Sheet1 are reserved for the several
>thousand (Pcount) answers. Do not use these columns for the following
>entries:
...
And you eat worksheet cells!
Why not create a new worksheet to store temporary results?
>Sub sum_perm()
...
>For i = 1 To NN
> For j = i + 1 To NN
> For k = j + 1 To NN
> For m = k + 1 To NN
> For n = m + 1 To NN
> For r = n + 1 To NN
> For s = r + 1 To NN
> For t = s + 1 To NN
> For u = t + 1 To NN
> For v = u + 1 To NN
...
Ah, brute force.
I've finally been tempted to do this myself. Brute force is
unfortunately necessary for this sort of problem, but there are better
control flows than hardcoded nested For loops.
Sub foo()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
Dim i As Long, n As Long, t As Double, u As Double
Dim x As Variant, y As Variant
Dim dv As New Dictionary, dc As New Dictionary
Dim re As New RegExp
re.Global = True
re.IgnoreCase = True
t = Range("A23").Value2 'target value - HARDCODED
For Each x In Range("A1:A20").Value2 'set of values - HARDCODED
If VarType(x) = vbDouble Then
If dv.Exists(x) Then
dv(x) = dv(x) + 1
ElseIf x = t Then
GoTo SolutionFound
ElseIf x < t Then
dc.Add Key:=Format(x), Item:=x
dv.Add Key:=x, Item:=1
End If
End If
Next x
For n = 2 To dv.Count
For Each x In dv.Keys
For Each y In dc.Keys
re.Pattern = "(^|\+)" & Format(x) & "(\+|$)"
If re.Execute(y).Count < dv(x) Then
u = dc(y) + x
If u = t Then
GoTo SolutionFound
ElseIf u < t Then
dc.Add Key:=y & "+" & Format(x), Item:=u
End If
End If
Next y
Next x
Next n
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"
Exit Sub
SolutionFound:
If IsEmpty(y) Then
y = Format(x)
n = dc.Count + 1
Else
y = y & "+" & Format(x)
n = dc.Count
End If
MsgBox Prompt:=y, Title:="Solution (" & Format(n) & ")"
End Sub
The initial loop loads a dictionary object (dv) with the numeric values
from the specified range, storing distinct values as keys and the
number of instances of each distinct values as items.
It tracks combinations of values from the original set using a
dictionary object (dc) in which the keys are the symbolic sums (e.g.,
"1+2+3") and the items are the evaluated numeric sums (e.g., 6). It
uses a regex Execute call to ensure that each distinct value appears no
more times than it appears in the original set.
New combinations are added to dc only when their sums are less than the
target value. This implicitly eliminates larger cardinality
combinations of sums which would exceed the target value, thus
partially mitigating the O(2^N) runtime that's unavoidable from this
sort of problem.
FWIW, my test data in A1:A20 was
692
506
765
97
47
949
811
187
537
217
687
443
117
248
580
506
449
309
393
507
and the formula for my target value in A23 was
=A2+A3+A5+A7+A11+A13+A17+A19
which evaluates to 3775. When I ran the macro above, it returned the
solution
687+506+765+97+47+949+187+537
which is equivalent to
=A11+A2+A3+A4+A5+A6+A8+A9
This looping logic doesn't work. If there are no matching combinations,
this will run a LONG, LONG, LONG time.
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.
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" <herbds...@yahoo.com> wrote in message
news:1125619841.0...@z14g2000cwz.googlegroups.com...
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.
'---- 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 ----
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?
--
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>
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...@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" <hrl...@aol.com> wrote in message
news:1125640838.2...@z14g2000cwz.googlegroups.com...
> Fixed the code.
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
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>>
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.
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 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.
I'm way out of my comfort zone for knowing what i'm taking about but could I
ask just a couple more questions.
In my example I'm only interested in 5 numbers pulled out of the master list
ie in the example below only these combnations are relevant
> 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
And these aren't
> 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 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
If it not too much hassle could you post a macro for me that will do this
for me.
I've simplified my actual real life problem by saying its 5 from 20. But its
actually 11 from about 150. Will the macro able to handle this or is there
too much number crunching involved ?
Thanks very much for your assistance so far.
Mike
"Harlan Grove" wrote:
> 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.
> ....
There are approximately 5.94 x10^23 possible combinations of 11 numbers out of 150 numbers,
compared to 1.8 x 10^6 when you are dealing with 5 out of 20. If the 20 number problem took .001
second, the 150 number problem would take 10 million years....
HTH,
Bernie
MS Excel MVP
> I've simplified my actual real life problem by saying its 5 from 20. But its
It's not the hassle, it's the point that if you can't modify the code,
how could you understand it? If you can't understand it, why would you
rely on it?
It's easy enough to extract the solution combinations with only 5
numbers from the exhaustive list, then calculate their respective
numbers of instances.
Finaly, I hate taking general code an making it overly particular.
However, if you don't want combinations of more than 11 numbers, change
the
For k = 2 To n
loop to
For k = 2 To 11
>I've simplified my actual real life problem by saying its 5 from 20. But its
>actually 11 from about 150. Will the macro able to handle this or is there
>too much number crunching involved ?
It may take a LONG TIME, but if there's pronounced variance in your 150
number set, then many branches of combinations should be eliminated
quickly. However, it's impossible to say for sure whether my macro
would fail or not. Worst case, you won't have sufficient memory to
store the intermediate combinations.
Still, post your data and your target sum. If you don't post any
description of the numbers, they'd just be numbers.
Only if the target value were approximately equal to a random sum
of 11 of the largest half of the numbers would there be anything
close to this number of combinations actually generated. If the
target value were approximately equal to 11 times the average of
the 150 numbers, combinations involving more than a few of the
numbers below the 30th percentile or above the 70th percentile
would have been ruled out in shorter combinations. This assumes
a reasonable variance in the 150 numbers.
Also, if 80% of that 0.001 second runtime were overhead, it'd
only take a few million years. I suspect the OP would have run out
of RAM in his lifetime.
Harlan,
I was guessing that the same sort of population statistics applied to both the 150 number set as the
20 number set, and that of the ~1sec (I may have blinked and mis-timed the routine), 99.9% was
overhead. (I didn't actually time it.) Still, even if the actual calc took only 1E-9 sec, it would
still take 10 years.... on a machine with unlimited memory. But I think we can agree that the
problem won't be solved on his PC anytime soon. And thanks, by the way, for the code. Works
sweetly.
Bernie
I agree. This sort of problem is usually too big to be handled.
There's a small chance that the OP's data has a bit more variance
than the sample posted, in which case there's some likelihood that
huge swaths of combinations would be eliminated early on. Still, I'd
figure Excel would need to churn through billions of combinations,
and that'd probably take days.
BTW, COMBIN(150,11) returns 1.48852E+16. You claimed 5.94171E+23,
which is PERMUT(150,11). Since addition is commutative, there's no
difference between the sum of one permutation and another. So it's
only necessary to check distinct combinations. That drops your
original 10 million year runtime estimate down to the order of one
year. Any appreciable elimination of smaller cardinality combinations
would drop the runtime to the order of a single day or several hours.
At that order runtime, memory would be the limiting factor.
A C 10
A D 20
A L 8
A S 1
AH 4
A Y 2
B M 8
C J 9
C P 11
C R 14
D K 6
D B 7
D D 8
D Z 0
D M 13
D V 9
E H 11
E D 13
F L 17
F Q 11
G H 12
G M 9
H P 4
J B 10
J C 10
J D 3
J P 15
J R 7
J S 0
J T 10
JA 0
J Z 2
JF 1
K D 3
K N 9
K P 6
L B 2
L M 0
L R 12
LT 7
M B 1
M Z 5
M D 9
M V 18
N H 10
O M 5
P C 9
P Z 11
P F 6
R E 1
R F 6
R K 2
R v 5
S A 3
S E 4
S K 3
S W 13
T H 17
T R 4
T S 7
T Z 15
U E 5
W G 12
W R 15
My aim is to find out all the combinations using 11 numbers that add up to
153.
If it would take far too long to run I could simplify it as below.
As 153 is at the top range,I don't believe that there would be many
combinations compared to the maximum amount possible.
It almost certainly uses AD 20 so perhaps I can look for 10 that total 133
and probably the lower numbers and duplicated numbers can be removed if its
still too unwieldy.
My data and total will change periodically -although my total will still be
very high- so would it be possible to type my total in cell A1 and my data
below it and then run the macro?
Thanks for all your help
MIke.
"Harlan Grove" wrote:
> Mike__ wrote...
> ....
> >In my example I'm only interested in 5 numbers pulled out of the master list
> ....
I was affraid of something like this. Your largest 9 numbers alone add
up to 144, and that 9th largest number is the first of 3 13s. There are
6 9s and 4 0s, so there are 72 (=3*6*4) combinations using the largest
8 numbers, one of the 13s, one of the 9s and one of the 0s.
Off the top of my head, I'd guess the number of combinations of 11
numbers from your set of just 64 that'd sum to 153 would number on the
order of thousands, and it'd require trillions of combinations to
determine with certainty.
>If it would take far too long to run I could simplify it as below.
>
>As 153 is at the top range,I don't believe that there would be many
>combinations compared to the maximum amount possible.
You're wrong. Intuition is useless for this sort of problem.
>It almost certainly uses AD 20 so perhaps I can look for 10 that total 133
>and probably the lower numbers and duplicated numbers can be removed if its
>still too unwieldy.
Again, intuition is useless. 20 isn't needed.
SUM(18,17,17,15,15,15,14,13,13,13) equals 150, and there are 4 3s, so
there are 4 instances of
18,17,17,15,15,15,14,13,13,13,3
SUM(17,17,15,15,15,14,13,13,13,12) equals 144, and there are 3 12s and
6 9s, so there are 18 instances of
17,17,15,15,15,14,13,13,13,12,9
SUM(18,17,17,15,15,15,14,13,13) equals 137, and there are 3 13s, so 3
different combinations of these 9 numbers. There are 3 12s and 4 4s, so
36 combinations of
18,17,17,15,15,15,14,13,13,12,4
4 11s and 4 5s, so 48 combinations of
18,17,17,15,15,15,14,13,13,11,5
5 10s and 4 6s, so 90 combinations of
18,17,17,15,15,15,14,13,13,10,6
6 9s and 4 7s, so 72 combinations of
18,17,17,15,15,15,14,13,13,9,7
and 3 8s, so 9 combinations of
18,17,17,15,15,15,14,13,13,8,8
SUM(18,17,17,15,15,15,14,13) equals 124, and there are 3 13s, so 3
different combinations of these 8 numbers. There are 3 12s, 4 11s and 4
6s, so 144 instances of
18,17,17,15,15,15,14,13,12,11,6
That's enough for me. As I said, the number of combinations of 11
numbers that sum to 153 is on the order of thousands, and most of those
won't include 20. To repeat, INTUITION IS USELESS.
FWIW, my macro came up with 828 *distinct* combinations of 11 numbers
that sum to 153. Given the repeat counts for most of your 64 numbers,
I'd guess there were around 4,000 combinations in total.
"Harlan Grove" wrote:
> Mike__ wrote...
> >These are the actual numbers I'm working with at the moment
> ....
After spending 20 mins listing out exactly what my data consists of, I find
its been lost in the ether.
If I just could summarize, perhaps you could tell me if its worth continuing.
You told me earlier that my data would create about 4000 possible
combinations.
However what I didnt mention is that my raw data is split into 4 distinct
groups and my 11 numbers that will total 153 must have 1 from Group A and 4
from Group B and any combination from Group C & D as long as I finish with 11
numbers. So this will reduce the combinations down to a more workable amount.
(hopefully)
Is it worth me telling you which data is in which group, could you program a
model that i could sort my data into the separate groups,or has it just got
too complicated?
I'll understand if its the latter.
Mike
Then I can leave you in peace !
Mike
One technique to calculate the number of solutions is to use the Generation
Function 1+z^i.
Excel can not do this of course, so we use a math program.
So, the real generation function goes out to our maximum value in our data
range. We take the product as i goes from 1 to 20.
gf = Product[1 + z^i, {i, 20}]
(1 + z)*(1 + z^2)*...(1 + z^19)*(1 + z^20)
We then look at the series expansion of this function, and pick the
coefficient associated with our z^153 term.
Timing[Coefficient[Series[gf, {z, 0, 153}], z, 153]]
{0.*Second, 3288}
So, we immediately see that the solution is 3288.
Given the numbers 1 thru 20, there are 3288 combinations that total 153.
And then we test our vba program to see if it finds all of them.
Stated another way, the above problem can also be worded from number theory
as "Given the number of Partitions of the integer 153 (of which there are
54,770,336,324), how many have unique solutions who's maximum value is 20?
Note that integer partitions have duplicates. For example, the partitions
of the number 4 are:
{4}, {3, 1}, {2, 2}, {2, 1, 1}, {1, 1, 1, 1}
Anyway, I just thought this might be interesting to share.
--
Dana DeLouis
Win XP & Office 2003
"Harlan Grove" <hrl...@aol.com> wrote in message
news:1126123638....@g49g2000cwa.googlegroups.com...
Given the numbers 1 - 20 (no duplicates), how many groups of 11 numbers
total 153?
gf = Product[x*y^j + 1, {j, 1, 20}]
There is no Series expansion in this version, but one would still want to
use a math program instead of Excel to do this.
m=20, n=11, t=153
Coefficient[Coefficient[Collect[Product[x*y^j+1,{j,m}],x],x,n],y,t]
As a function, there are 72 combinations of 11 numbers that total 153
Timing[Fx[20, 11, 153]]
{0.016*Second, 72}
Given the numbers 1-64, there are about 3.7 million combinations of 11
numbers that total 153. Timing seems slow, so I'm sure there's a more
efficient algorithm.
Timing[Fx[64, 11, 153]]
{2.5*Second, 3,699,726}
--
Dana DeLouis
Win XP & Office 2003
<snip>
"mellowe" <melani...@hotmail.com> wrote in message
news:1130097197.4...@g47g2000cwa.googlegroups.com...