Number Combination
 

Hi

This is going to be horribly mathematically intensive to do but I'm hoping
someone will know how to do it - I'm very happy with VBA but can't quite get
my head round this one....

I've got list of up to 120 numbers in column A. These numbers are dollar
values and may be positive or negative.

Some combination(s) (when summed) of UP TO 10 cells will equal the number
that I'm looking for. How do I find all the combinations that match the
number I'm looking for?

Here's a much simplified version:

A1 = 10
A2 = 20
A3 = 30
A4 = 40
A5 = 50
A6 = -20

If the total I'm looking for is 50, it needs to return the cell addresses
(or their values)

A1 + A4 (10+40)
A2 + A3 (20+30)
A3+A4+A6 (30+40-20)
A5 (50) and so on and on and on......

It doesn't matter (almost) how long it takes to run - just being able to get
the answer is the really important thing.

Any bright ideas?

Many thanks

David

Number Combination
 

Copy the code below (written by Harlan Grove) into a code module, and set the
references as
instructed in the comments.

Then run findsums and highlight the ranges with your values when prompted.

HTH,
Bernie
MS Excel MVP

Option Explicit
'Begin VBA Code

Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

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 ----

--
Regards,
Tom Ogilvy


"David Coleman" wrote:

Hi

This is going to be horribly mathematically intensive to do but I'm hoping
someone will know how to do it - I'm very happy with VBA but can't quite get
my head round this one....

I've got list of up to 120 numbers in column A. These numbers are dollar
values and may be positive or negative.

Some combination(s) (when summed) of UP TO 10 cells will equal the number
that I'm looking for. How do I find all the combinations that match the
number I'm looking for?

Here's a much simplified version:

A1 = 10
A2 = 20
A3 = 30
A4 = 40
A5 = 50
A6 = -20

If the total I'm looking for is 50, it needs to return the cell addresses
(or their values)

A1 + A4 (10+40)
A2 + A3 (20+30)
A3+A4+A6 (30+40-20)
A5 (50) and so on and on and on......

It doesn't matter (almost) how long it takes to run - just being able to get
the answer is the really important thing.

Any bright ideas?

Many thanks

David

Number Combination
 

Hi and thanks for the speedy response

It works perfectly with my whole integer list of numbers and can find single
numbers from the real list (below) but won't pull out additions....

$108,482.17
$0.00
$0.00
$1,089.14
$500.00
$676,323.27
$5,632,171.44
$1,782,571.72
$240,743.18
$3,122.00
$265.00
$46,862.16
-$1,057,013.59
$9,551.62
$5,903,539.61


Above is e a subset of the numbers - it will find 500 or 1089.14 but not
1589.14. I've tried the numbers with no formatting, as currency and as two
decimal numbers.

Can you possibly help any further?

Many thanks

David


"Tom Ogilvy" wrote in message
...
Copy the code below (written by Harlan Grove) into a code module, and set
the
references as
instructed in the comments.

Then run findsums and highlight the ranges with your values when
prompted.

HTH,
Bernie
MS Excel MVP

Option Explicit
'Begin VBA Code

Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

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 ----

--
Regards,
Tom Ogilvy


"David Coleman" wrote:

Hi

This is going to be horribly mathematically intensive to do but I'm
hoping
someone will know how to do it - I'm very happy with VBA but can't quite
get
my head round this one....

I've got list of up to 120 numbers in column A. These numbers are dollar
values and may be positive or negative.

Some combination(s) (when summed) of UP TO 10 cells will equal the number
that I'm looking for. How do I find all the combinations that match the
number I'm looking for?

Here's a much simplified version:

A1 = 10
A2 = 20
A3 = 30
A4 = 40
A5 = 50
A6 = -20

If the total I'm looking for is 50, it needs to return the cell addresses
(or their values)

A1 + A4 (10+40)
A2 + A3 (20+30)
A3+A4+A6 (30+40-20)
A5 (50) and so on and on and on......

It doesn't matter (almost) how long it takes to run - just being able to
get
the answer is the really important thing.

Any bright ideas?

Many thanks

David

Number Combination
 

Multiply your numbers by 100 and truncate them so you are sure the don't
have a decimal portion. Do the same for the total you are trying to reach.

--
Regards,
Tom Ogilvy

"David Coleman" wrote in message
...
Hi and thanks for the speedy response

It works perfectly with my whole integer list of numbers and can find
single numbers from the real list (below) but won't pull out additions....

$108,482.17
$0.00
$0.00
$1,089.14
$500.00
$676,323.27
$5,632,171.44
$1,782,571.72
$240,743.18
$3,122.00
$265.00
$46,862.16
-$1,057,013.59
$9,551.62
$5,903,539.61


Above is e a subset of the numbers - it will find 500 or 1089.14 but not
1589.14. I've tried the numbers with no formatting, as currency and as
two decimal numbers.

Can you possibly help any further?

Many thanks

David


"Tom Ogilvy" wrote in message
...
Copy the code below (written by Harlan Grove) into a code module, and set
the
references as
instructed in the comments.

Then run findsums and highlight the ranges with your values when
prompted.

HTH,
Bernie
MS Excel MVP

Option Explicit
'Begin VBA Code

Sub findsums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

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 ----

--
Regards,
Tom Ogilvy


"David Coleman" wrote:

Hi

This is going to be horribly mathematically intensive to do but I'm
hoping
someone will know how to do it - I'm very happy with VBA but can't quite
get
my head round this one....

I've got list of up to 120 numbers in column A. These numbers are
dollar
values and may be positive or negative.

Some combination(s) (when summed) of UP TO 10 cells will equal the
number
that I'm looking for. How do I find all the combinations that match the
number I'm looking for?

Here's a much simplified version:

A1 = 10
A2 = 20
A3 = 30
A4 = 40
A5 = 50
A6 = -20

If the total I'm looking for is 50, it needs to return the cell
addresses
(or their values)

A1 + A4 (10+40)
A2 + A3 (20+30)
A3+A4+A6 (30+40-20)
A5 (50) and so on and on and on......

It doesn't matter (almost) how long it takes to run - just being able to
get
the answer is the really important thing.

Any bright ideas?

Many thanks

David