combination of numbers

Here's an example using the solver add-in

http://tinyurl.com/4doog

--
Regards,

Peo Sjoblom

(No private emails please)


"ErnestoMarti" <ErnestoMarti.1umz2a_1125504302.683@excelforum-nospam.com>
wrote in message
news:ErnestoMarti.1umz2a_1125504302.683@excelforum-nospam.com...
>
> undefined
> Hello!!!! The problem that I explain below is one that i have for a
> long time... hope someone can understand it...!!
> Is there any option in Excel, if I have a list of numbers (for example
> 20 different numbers), I want to know which combination of these
> numbers are the sum of "X" number???
>
>
> --
> ErnestoMarti
> ------------------------------------------------------------------------
> ErnestoMarti's Profile:
> http://www.excelforum.com/member.php...o&userid=26836
> View this thread: http://www.excelforum.com/showthread...hreadid=400817
>

Ernesto,

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.1umz2a_1125504302.683@excelforum-nospam.com> wrote in message
news:ErnestoMarti.1umz2a_1125504302.683@excelforum-nospam.com...
>
> undefined
> Hello!!!! The problem that I explain below is one that i have for a
> long time... hope someone can understand it...!!
> Is there any option in Excel, if I have a list of numbers (for example
> 20 different numbers), I want to know which combination of these
> numbers are the sum of "X" number???
>
>
> --
> ErnestoMarti
> ------------------------------------------------------------------------
> ErnestoMarti's Profile: http://www.excelforum.com/member.php...o&userid=26836
> View this thread: http://www.excelforum.com/showthread...hreadid=400817
>

Here is a fast way (.4 sec) to find a set o 10 numbers (Num_Sel) out of
a set of 20 numbers (Bin1) that add up to (Total).
The first 10 columns of your Sheet1 are reserved for the several
thousand (Pcount) answers. Do not use these columns for the following
entries:
Setup: Tools > Options > General > R1C1 reference style
Create a 20 row vector named Bin1 and enter your 20 numbers.
Name a cell Numbers and enter
=COUNTA(Bin1)
Name a cell Num_Sel and enter 10
Name a cell CombTot and enter
=INT(COMBIN(Numbers,Num_Sel)/25)
Name a cell Total and enter your desired sum.
Name a cell Pcount.
Insert > Name > Define > Names > Results
Refers to:
=OFFSET(INDIRECT("Sheet1!C1:C"&(Num_Sel),0),1,,CombTot)
Copy the following macro into a VBA module and run it.
For other values of Num_Sel, expand or collapse the macro and modify
the spreadsheet formulas.

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

Herbert Seidenberg wrote...
>Here is a fast way (.4 sec) to find a set o 10 numbers (Num_Sel) out of
>a set of 20 numbers (Bin1) that add up to (Total).
....

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

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
>

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.