I have a list of numbers. I need to know which numbers when added together,
give me a specific total. In other words, which items can I purchase from a
list with my $50.00?

Thanks.

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


--
Kind regards,

Niek Otten
Microsoft MVP - Excel


"esilverb" wrote in message
...
I have a list of numbers. I need to know which numbers when added together,
give me a specific total. In other words, which items can I purchase from
a
list with my $50.00?

Thanks.

Here's another macro called 'Combos_Range' that will list totals for the
combinations of selected cells for you.
--
Hope this helps.
Thanks in advance for your feedback.
Gary Brown

'/====================================/
' Sub Purpose: 07/01/2008
' This program will give the addition of each
' combination of cells selected within a range
' of values. The # of combinations is calculated
' as [2^(# of cells selected)] - 1
'
'# of
'Items Combinations Seconds
'1 1 -
'2 3 -
'3 7 -
'4 15 -
'5 31 -
'6 63 -
'7 127 -
'8 255 -
'9 511 -
'10 1,023 -
'11 2,047 -
'12 4,095 -
'13 8,191 -
'14 16,383 -
'15 32,767 -
'16 65,535 -
'17 131,071 1
'18 262,143 2
'19 524,287 5
'20 1,048,575 9
'21 2,097,151 17
'22 4,194,303 33
'23 8,388,607 67
'24 16,777,215 133
'25 33,554,431 257
'26 67,108,863 524
'27 134,217,727 1,048
'28 268,435,455 2,096
'29 536,870,911 4,192
'30 1,073,741,823 8,384
'31 2,147,483,647 16,768
'32 4,294,967,295 33,536
'33 8,589,934,591 67,072
'34 17,179,869,183 134,144
'35 34,359,738,367 268,288
'36 68,719,476,735 536,576
'37 137,438,953,471 1,073,152
'38 274,877,906,943 2,146,304
'39 549,755,813,887 4,292,608
'40 1,099,511,627,775 8,585,216
'41 2,199,023,255,551 17,170,432
'42 4,398,046,511,103 34,340,864
'43 8,796,093,022,207 68,681,728
'44 17,592,186,044,415 137,363,456
'45 35,184,372,088,831 274,726,912
'46 70,368,744,177,663 549,453,824
'47 140,737,488,355,327 1,098,907,648
'48 281,474,976,710,655 2,197,815,296
'49 562,949,953,421,311 4,395,630,592
'50 1,125,899,906,842,620 8,791,261,184
'51 2,251,799,813,685,250 17,582,522,368
'52 4,503,599,627,370,490 35,165,044,736
'
'/====================================/
Sub Combos_Range()
Dim aryA()
Dim aryNum() As Double
Dim aryExp() As String
Dim dtStartTime As Date
Dim dtEndTime As Date
Dim dblLastRow As Double, dblRow As Double
Dim dblStartRange As Double
Dim dblEndRange As Double
Dim i As Double
Dim x As Double, iMaxCount As Double
Dim iMaxRows As Double
Dim z As Double, R As Double
Dim y As Double
Dim iCount As Double
Dim dblOrigCalcStatus As Double
Dim iWorksheets As Integer
Dim iCol As Integer
Dim objCell As Object
Dim rngInput As Range
Dim strStartRange As String
Dim strEndRange As String
Dim strOriginalAddress As String
Dim strRngInputAddress As String
Dim strWorksheetName As String
Dim strResultsTableName As String
Dim strType As String
Dim varAnswer As Variant

' On Error Resume Next
On Error GoTo err_Sub

'save calculation setting
dblOrigCalcStatus = Application.Calculation

'set workbook to manual
Application.Calculation = xlManual

'/----------start-up Variables-------------/
strResultsTableName = "Combinations_Listing_Range"
strOriginalAddress = Selection.Address
strWorksheetName = ActiveSheet.name
iMaxCount = 30 ' 1,073,741,823 combinations
' - about 2.5 hrs of calc time
iMaxRows = 65000
'/----------end start-up Variables---------/

strStartRange = InputBox(Prompt:= _
"Enter the Starting Value for Range of Values to be " & _
"returned in Combinations " & vbCr & "or" & vbCr & _
"'OK' for default of " & _
"-999,999,999,999.99." & vbCr & vbCr, _
Title:="Combinations....START", Default:="-999999999999.99")

If Len(strStartRange) = 0 Then
GoTo exit_Sub
End If

dblStartRange = Val(strStartRange)

strEndRange = InputBox(Prompt:= _
"Enter the Ending Value for Range of Values to be " & _
"returned in Combinations " & vbCr & "or" & vbCr & _
"'OK' for default of " & _
"+999,999,999,999.99." & vbCr & vbCr, _
Title:="Combinations....END", Default:="999999999999.99")

If Len(strEndRange) = 0 Then
GoTo exit_Sub
End If

dblEndRange = Val(strEndRange)

Set rngInput = _
Application.InputBox(Prompt:= _
"Select Range of Numbers to be used as input for " & _
"combinations output" & vbCr & vbCr & _
"Note: Currently limited to " & _
iMaxCount & " cells or less", _
Title:="Combinations....RANGE", _
Default:=strOriginalAddress, Type:=8)

'get how many cells have been selected and location
iCount = rngInput.Count
strRngInputAddress = rngInput.Address

Select Case iCount
Case 0
MsgBox "No cells have been selected." & vbCr & _
vbCr & "Process aborted...", _
vbExclamation + vbOKOnly, _
"Warning..."
GoTo exit_Sub
Case 1 To iMaxCount
i = (2 ^ iCount) - 1
varAnswer = MsgBox("The " & iCount & _
" selected cell(s) will produce and review " & _
Application.WorksheetFunction.Text(i, "#,##") & _
" combinations." & vbCr & "Do you wish to continue?", _
vbInformation + vbYesNo, _
"Combinations...")
If varAnswer = vbNo Then Exit Sub
Case Is iMaxCount
varAnswer = _
MsgBox("Only the first " & iMaxCount & _
" cells in the range <<< " & _
strRngInputAddress & " will be processed." & vbCr & _
vbCr & "Continue?", vbExclamation + vbYesNo, "Warning")
If varAnswer = vbNo Then Exit Sub
End Select

dtStartTime = Now()

If iCount iMaxCount Then iCount = iMaxCount

'now that we can calculate the actual dimensions
' we can re-dimension the arrays
ReDim aryNum(1 To iCount)
ReDim aryA(1 To iMaxRows, 1 To 2)
ReDim aryExp(1 To iCount)

'populate the array with the values in the selected cells
i = 0
For Each objCell In rngInput
'check to see if all selected values are numbers
Select Case VarType(objCell)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, _
vbDecimal, vbByte, vbDate
strType = "Number"
Case Else
strType = "Other"
End Select

If strType < "Number" Then
MsgBox _
"Only Numbers may be selected for this process." & _
vbCr & vbCr & _
Chr(34) & objCell.value & Chr(34) & " in Cell " & _
objCell.Address & _
" is not valid. Process has stopped.", _
vbInformation + vbOKOnly, "Warning..."
GoTo exit_Sub
End If

'put numbers in array
i = i + 1
If i iMaxCount Then Exit For
aryNum(i) = objCell.Value2
aryExp(i) = _
Application.WorksheetFunction.Text(objCell.value, "@")
Next objCell

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(ActiveSheet.name)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Amount"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Combo"
Range("A1:B1").Font.Bold = True

On Error Resume Next
Range("A2").Select

'initialize variable to desired values
z = 1
y = 1
dblRow = 2
iCol = 1

'add the first element
aryA(y, 1) = aryNum(z)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")

'initialize arrays with combos
For z = 2 To iCount
y = y + 1
aryA(y, 1) = aryNum(z)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")
For x = 1 To ((2 ^ (z - 1)) - 1)
y = y + 1
aryA(y, 1) = aryA(x, 1) + aryNum(z)
aryA(y, 2) = aryA(x, 2) & " + " & _
Format(aryExp(z), "#,##0.00")
Next x
Next z

'put array info into worksheet
For R = 1 To y
If dblStartRange <= aryA(R, 1) And _
dblEndRange = aryA(R, 1) Then
Cells(dblRow, iCol) = aryA(R, 1)
Cells(dblRow, iCol + 1) = aryA(R, 2)
dblRow = dblRow + 1
If dblRow = iMaxRows Then
dblRow = 2
iCol = iCol + 4
End If
End If
Next R

'format worksheet
Cells.Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A2"), _
Order1:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
ActiveWindow.Zoom = 75

Range("A1:B1").Select

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

Selection.Font.Underline = xlUnderlineStyleSingle
Columns("A:A").Select
Selection.NumberFormat = _
"_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Columns("B:B").Select
If Selection.ColumnWidth 75 Then
Selection.ColumnWidth = 75
End If
Selection.HorizontalAlignment = xlLeft

Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
dblLastRow = dblLastRow + 1

'adjust info for max # of processed cells
If iCount iMaxRows Then iCount = iMaxRows

Application.ActiveCell.Formula = "=Text(SUBTOTAL(3,A3:A" & _
dblLastRow + 10 & ")," & Chr(34) & "#,##0" & _
Chr(34) & ") & " & _
Chr(34) & " Combinations found for " & _
Application.WorksheetFunction.Text(iCount, "#,##") & _
" selections in range: " & _
strRngInputAddress & " - with Range: " & _
Format(dblStartRange, "#,##0.00") & " to " & _
Format(dblEndRange, "#,##0.00") & Chr(34)
Selection.Font.Bold = True

Cells.Select
With Selection.Font
.name = "Tahoma"
.Size = 10
End With

Range("A3").Select
ActiveWindow.FreezePanes = True

dtEndTime = Now()
' Debug.Print _
Round((dtEndTime - dtStartTime) * 24 * 60 * 60, 2) & _
" seconds"

Application.Dialogs(xlDialogWorkbookName).Show

exit_Sub:
On Error Resume Next
Application.Calculation = dblOrigCalcStatus
Set rngInput = Nothing
Exit Sub

err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: Combos_Range - Module: " & _
"Mod_Combinations_List_All - " & Now()
GoTo exit_Sub

End Sub
'/====================================/