Is there a formula or look up function within excel that will do the following:

Locate within a range of cells the cells that when summed together equal a
specified amount.

For example: I am looking for 22,000 amount that is a combination of the
records within a range of cells.

Will excel show me the possible results even if it were many?

Help and thanks.

My standard reply:

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 dont know if this
has been corrected later.
Note the requirements for your settings documented in the code itself

Peos 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
==================================================
Harlans 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 ----




"KUNA" wrote in message
...
Is there a formula or look up function within excel that will do the
following:

Locate within a range of cells the cells that when summed together equal a
specified amount.

For example: I am looking for 22,000 amount that is a combination of the
records within a range of cells.

Will excel show me the possible results even if it were many?

Help and thanks.

This helped tremendously!! Thank you so much.

"Niek Otten" wrote:

My standard reply:

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 dont know if this
has been corrected later.
Note the requirements for your settings documented in the code itself

Peos 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
==================================================
Harlans 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 ----




"KUNA" wrote in message
...
Is there a formula or look up function within excel that will do the
following:

Locate within a range of cells the cells that when summed together equal a
specified amount.

For example: I am looking for 22,000 amount that is a combination of the
records within a range of cells.

Will excel show me the possible results even if it were many?

Help and thanks.

Hi Kuna,

See my post in: http://www.tek-tips.com/viewthread.cfm?qid=1485698

--
Cheers
macropod
[Microsoft MVP - Word]


"KUNA" wrote in message ...
Is there a formula or look up function within excel that will do the following:

Locate within a range of cells the cells that when summed together equal a
specified amount.

For example: I am looking for 22,000 amount that is a combination of the
records within a range of cells.

Will excel show me the possible results even if it were many?

Help and thanks.

One more option since this was posted in the functions group...
Use an array formula which sums every combination of values
(for 16 values there are 2^16=65536 combinations)

Suppose your values are in A2:A17 and A1=22000, B1=1.
Select B2:B17 and enter the formula below with CTRL+SHIFT+ENTER:
(Other solutions are easily found by setting B1=2,3,...)

=MOD(MOD(SMALL(ABS(ROUND((
(MOD(ROW(A:A)/2^0,2)=1)*A2+
(MOD(ROW(A:A)/2^1,2)=1)*A3+
(MOD(ROW(A:A)/2^2,2)=1)*A4+
(MOD(ROW(A:A)/2^3,2)=1)*A5+
(MOD(ROW(A:A)/2^4,2)=1)*A6+
(MOD(ROW(A:A)/2^5,2)=1)*A7+
(MOD(ROW(A:A)/2^6,2)=1)*A8+
(MOD(ROW(A:A)/2^7,2)=1)*A9+
(MOD(ROW(A:A)/2^8,2)=1)*A10+
(MOD(ROW(A:A)/2^9,2)=1)*A11+
(MOD(ROW(A:A)/2^10,2)=1)*A12+
(MOD(ROW(A:A)/2^11,2)=1)*A13+
(MOD(ROW(A:A)/2^12,2)=1)*A14+
(MOD(ROW(A:A)/2^13,2)=1)*A15+
(MOD(ROW(A:A)/2^14,2)=1)*A16+
(MOD(ROW(A:A)/2^15,2)=1)*A17
-A1)*10^8,-6))+ROW(A:A),B1),10^6)/2
^{0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15},2)=1

This returns TRUE or FALSE next to each value to include in the sum,

"KUNA" wrote:

Is there a formula or look up function within excel that will do the following:

Locate within a range of cells the cells that when summed together equal a
specified amount.

For example: I am looking for 22,000 amount that is a combination of the
records within a range of cells.

Will excel show me the possible results even if it were many?

Help and thanks.