Help please...

I have a single column of data that is over 256 rows. They are dollar
amounts and I am looking for every possible combination of the numbers that
equal a specific dollar amount. It could be that is only a sum of two
numbers or it could be three, four or five or more, however, 95% of the time
it is only the sum of two numbers. I haven't been able to figure out from
the help feature how to solve this problem. I was manually doing it by
copying the data and transposing it but this only works when I have less than
255 rows.

A simple example of my problem would be this...
My data:
1
2
3
4
7
and I am looking for every possible combination that gives me 9. Easy to do
in my head but I can't when I have so many rows.

Anyone able to guide me on this?

Thanks in advance.

Hi Michael,

A long answer....

--
Kind regards,

Niek Otten
Microsoft MVP - Excel

Find numbers that add up to a specified sum.
Niek Otten
05-Apr-06

This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited
set of data
One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan
Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly,
it will miss that combination. I don't know if this has been corrected later.
Note the requirements for your settings documented in the code itself

Peo's solution:
==================================================
One way but you need the solver add-in installed (it comes with
excel/office,check under toolsadd-ins)
put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc}
in the adjacent cells
in C2 put 8, in D2 put
=SUMPRODUCT(A2:A7,B2:B7)
select D2 and do toolssolver, set target cell $D$2 (should come up
automatically if selected)
Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject
to the constraints of:
in Cell reference put
$B$2:$B$7
from dropdown select Bin, click OK and click Solve, Keep solver solution
and look at the table
2 1
4 0
5 0
6 1
9 0
13 0
there you can see that 4 ones have been replaced by zeros and the adjacent
cells to the 2 ones
total 8
--
Regards,
Peo Sjoblom
==================================================
Harlan's solution:


'Begin VBA Code

' By Harlan Grove

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

"Michael" wrote in message ...
| Help please...
|
| I have a single column of data that is over 256 rows. They are dollar
| amounts and I am looking for every possible combination of the numbers that
| equal a specific dollar amount. It could be that is only a sum of two
| numbers or it could be three, four or five or more, however, 95% of the time
| it is only the sum of two numbers. I haven't been able to figure out from
| the help feature how to solve this problem. I was manually doing it by
| copying the data and transposing it but this only works when I have less than
| 255 rows.
|
| A simple example of my problem would be this...
| My data:
| 1
| 2
| 3
| 4
| 7
| and I am looking for every possible combination that gives me 9. Easy to do
| in my head but I can't when I have so many rows.
|
| Anyone able to guide me on this?
|
| Thanks in advance.
|

Thank you. I will give it a shot.

"Niek Otten" wrote:

Hi Michael,

A long answer....

--
Kind regards,

Niek Otten
Microsoft MVP - Excel

Find numbers that add up to a specified sum.
Niek Otten
05-Apr-06

This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited
set of data
One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan
Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly,
it will miss that combination. I don't know if this has been corrected later.
Note the requirements for your settings documented in the code itself

Peo's solution:
==================================================
One way but you need the solver add-in installed (it comes with
excel/office,check under toolsadd-ins)
put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc}
in the adjacent cells
in C2 put 8, in D2 put
=SUMPRODUCT(A2:A7,B2:B7)
select D2 and do toolssolver, set target cell $D$2 (should come up
automatically if selected)
Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject
to the constraints of:
in Cell reference put
$B$2:$B$7
from dropdown select Bin, click OK and click Solve, Keep solver solution
and look at the table
2 1
4 0
5 0
6 1
9 0
13 0
there you can see that 4 ones have been replaced by zeros and the adjacent
cells to the 2 ones
total 8
--
Regards,
Peo Sjoblom
==================================================
Harlan's solution:


'Begin VBA Code

' By Harlan Grove

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

"Michael" wrote in message ...
| Help please...
|
| I have a single column of data that is over 256 rows. They are dollar
| amounts and I am looking for every possible combination of the numbers that
| equal a specific dollar amount. It could be that is only a sum of two
| numbers or it could be three, four or five or more, however, 95% of the time
| it is only the sum of two numbers. I haven't been able to figure out from
| the help feature how to solve this problem. I was manually doing it by
| copying the data and transposing it but this only works when I have less than
| 255 rows.
|
| A simple example of my problem would be this...
| My data:
| 1
| 2
| 3
| 4
| 7
| and I am looking for every possible combination that gives me 9. Easy to do
| in my head but I can't when I have so many rows.
|
| Anyone able to guide me on this?
|
| Thanks in advance.
|

Michael,
If your special case is only to find numbers in which the digits sum to 9
you are in mathematically in luck:
Any number with digits summing to 9 is also evenly divisble by 9. Therefore
you can use the MOD function. IF(MOD(A1,9)=0,whatever you want)

I am curious why you want numbers with digits summing to 9. Another math
fact is "If you accidentally transpose any 2 digits in a number, then the
size of the error will always be even divisble by 9."
1234
1324
difference is 90 which is obviously divisble by 9

43
34
difference is 9

This is old accounting trick to help identify errors in manually entered
columns of numbers. A common error is to transpose two digits.

Math lesson is over.

KIM

"Michael" wrote:

Help please...

I have a single column of data that is over 256 rows. They are dollar
amounts and I am looking for every possible combination of the numbers that
equal a specific dollar amount. It could be that is only a sum of two
numbers or it could be three, four or five or more, however, 95% of the time
it is only the sum of two numbers. I haven't been able to figure out from
the help feature how to solve this problem. I was manually doing it by
copying the data and transposing it but this only works when I have less than
255 rows.

A simple example of my problem would be this...
My data:
1
2
3
4
7
and I am looking for every possible combination that gives me 9. Easy to do
in my head but I can't when I have so many rows.

Anyone able to guide me on this?

Thanks in advance.