Which Numbers Sum to Target
Download Recursion1.zip
The problem: You have a list of numbers, some of which sum up to another number. If you have 10 numbers, there are 2^10 or 1,024 possible combinations. A pretty daunting task.
Recursion to the rescue. This file allows you to enter a list of numbers and a target, and it will tell you which numbers sum to the target.
Naishad Rajani wrote the code and Jimmy Day prettied up the UI. I only have the distinction of distributing the file. I did spend quite a bit of time stepping through this macro about five years ago. I had never used recursion at the time, and it was difficult to get my head around.
A word of warning. Twenty items in the list seems to be about the upper limit from a time perspective. Any more than that and it takes too long to process.
Harlan Grove’s procedure kicks the recursive code’s butt.
For what it’s worth, I’ve used the same recursive version for the last 7 years or so - but I think it was originally posted on the web by Michel Claes.
Copy the code below 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.
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) 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) = 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 —-
I tried the workbook: Impressive!
Would like to try your code too Dick but is it possible you cannot set the reference to
“Microsoft VBScript Regular Expressions 1.0 or higher”
in XL97?
Brgds Sige
Bernie graciously sent me a copy of the code from Michael a while ago. I modified it a tad and added it as a button on a custom menu. Here is my code. It basically is the same as Bernies except that it finds all of the solutions and lets the user see the possibles one after the other. Bernies actually show the last of possibly many solutions. Select a range and run the code. It will prompt you for a number. Then just let it rip. If it is taking too long hit escape. If the range is more than 25 elements it warns you that this could take a while…
‘ Original solution created by
‘ Michel Claes
Private Const intWarningElements As Integer = 25
Private dblTargetValue As Double
Private intElements As Integer
Private intCurrentSolutionFlags() As Integer
Private intBestSolutionFlags() As Integer
Private dblElementValues() As Double
Private dblBestSolution As Double
Private rngRangeToSearch As Range
Private blnFound As Boolean
Public Sub FindSolution()
Dim intCounter As Integer
Dim wks As Worksheet
Set wks = ActiveSheet
Set rngRangeToSearch = Intersect(Selection, wks.UsedRange)
If rngRangeToSearch Is Nothing Then Set rngRangeToSearch = ActiveCell
dblBestSolution = 0
dblTargetValue = GetTargetValue
intElements = rngRangeToSearch.Count
ReDim dblElementValues(intElements)
ReDim intBestSolutionFlags(intElements)
ReDim intCurrentSolutionFlags(intElements)
If intElements > intWarningElements Then
If MsgBox(”This may take a VERY long time to execute. Did you wish ” & _
“to proceed?”, vbYesNo + vbCritical, “Proceed???”) = vbYes Then
Call ProcessSelection
End If
Else
Call ProcessSelection
End If
If blnFound = False Then
Call StoreSolution
Else
MsgBox “The search is completed.”, vbInformation, “Complete”
End If
Set wks = Nothing
End Sub
Private Sub ProcessSelection()
Dim intCounter As Integer
Application.StatusBar = “Processing. Please Wait.”
For intCounter = 1 To intElements
On Error Resume Next
dblElementValues(intCounter) = rngRangeToSearch.Item(intCounter)
On Error GoTo 0
Next intCounter
Evaluate 0, 1
Application.StatusBar = False
End Sub
Private Sub StoreSolution()
Dim intCounter As Integer
Dim rngFound As Range
For intCounter = 1 To intElements
If intBestSolutionFlags(intCounter) = 1 Then
If rngFound Is Nothing Then
Set rngFound = rngRangeToSearch.Item(intCounter)
Else
Set rngFound = Union(rngRangeToSearch.Item(intCounter), rngFound)
End If
End If
Next intCounter
If rngFound Is Nothing Then Set rngFound = ActiveCell
rngFound.Select
If Round(Application.Sum(rngFound), 4) Round(dblTargetValue, 4) Then _
MsgBox “An exact match was not found. The closest match is:” & _
vbCrLf & vbCrLf & vbTab & _
Format(Application.Sum(rngFound), “#,##0.00″) & _
vbCrLf & vbCrLf & “A difference of:” & vbCrLf & vbCrLf & vbTab & _
Format(Application.Sum(rngFound) - dblTargetValue, “#,##0.00″)
Set rngFound = Nothing
End Sub
Private Sub CopySolutionFlags()
Dim intCounter As Integer
For intCounter = 1 To intElements
intBestSolutionFlags(intCounter) = intCurrentSolutionFlags(intCounter)
Next intCounter
End Sub
Private Sub Evaluate(ByVal total As Double, ByVal pos As Integer)
On Error GoTo HandleCancel
Application.EnableCancelKey = xlErrorHandler
If pos 0 Then blnInputOk = True
End If
Do While blnInputOk = False
MsgBox “The value entered must be a number not equal to 0. ” & _
“Please try again.”, vbInformation, “Input Error”
strInput = InputBox(”Please enter the target value.”, “Target Value”)
If strInput = Empty Then End
If Not IsNumeric(strInput) Then
If CDbl(strInput) 0 Then blnInputOk = True
End If
Loop
GetTargetValue = CDbl(strInput)
End Function
Jim,
Did you have a problem pasting your code? The last sub has an End Function statement rather than an End Sub, so there appears to be a chunk missing.
Bernie
Bernie or Jim: Can you either of you email the workbook to me. Pasting code in these comments stinks because of the html translation. Thanks.
Jim,
Can you you email the workbook to me. I have the same problem as Dick.
Thanks
Mike
mchaput1954temp-a@yahoo.com
Dick, Bernie and Mike. I sent you the file. If you did not get it let me know…
Got it Jim. I’m planning on posting it for download if nobody has a problem with that.
Dick/Jim T,
Can either of you send me the workbook also, I am having the same problem. The recursion1.zip file will not download for me from the link for some reason.
My email is mawatson64@yahoo.com
Can either of you send me the workbook also, I am having the same problem. The recursion1.zip file will not download for me from the link for some reason.
If you guys can wait until Wednesday, I will have it available for download.
Bernie,
It looks like there is an error in the line
If Abs(t - y) t Then dcn.Add Key:=”+” & _
Is there supposed to be something between “(t-y)” and the “t”
Bernie,
There is also an issue with
Call recsoln
There is nothing called “recsoln” for it to call??
Fred: It’s no doubt a greater than or less than sign which Wordpress incorrectly interprets as html. Posting code in the comments of this blog stinks and I take full responsibility for it. The ‘recsoln’ I can’t account for.
Hello,
I was wondering if the code can be modified slightly to gain all possible combinations that are less than or equal to a target number.
Thanks,
Scott
Sorry, I also would like to have a constraint that the combination of numbers always has to contain the same amount of cell references (ie. combinations have to have 11 different cell references (numbers))
Eg. 250 numbers, exactly 11 numbers must be chosen, the sum of these numbers must be less than or equal to 1000.
Thanks,
Scott
Is this file available for download? I only see the recursion1.zip. If not, can someone mail it to me at zfraile@gmail.com?
Thanks!
Hi Dick,
Can we see the Recursion2 available for download. Just love that code.
Regards
kanwaljit
kanwaljit: I looked for it last night, but couldn’t find it. I’m sure it’s there somewhere. I’ll look again tonight and hopefully get it posted this weekend.
I don’t know how well behaved Bernie’s post or various revisions of Harlan’s code or any of the variants of the recursive solutions are. My gut instinct would be to ask if any of them follow the developments from the world of Operations Research, specifically, the Simplex method. Luckily, Solver uses just that method when told that the problem is a “linear problem.” For a template, see
Find a set of amounts that match a target value
http://www.tushar-mehta.com/excel/tips/template-set-match.html
Hi Dick,
Thanks a million to both of you. I was Delighted to see the reply. Thanks Dick, would love to wait for the file !
Thanks a lot Tushar, I really got mad searching for something to do that. Just saw yours comment. Feels jubilated, just on seeing the link. A link to something on yours site. Must be perfect, I believe. Let me try that.
Best Regards
Kanwaljit
Hi,
It seems the Recursion file given on this site suits my requirements in a better way. While I am trying my best to make the things work for me, it would help me a lot, If I have a chance to try the Said 2nd Recursion.zip. Dick, Do upload the file, if you can find it. Hopefully.
Thanks and Regards
Kanwaljit
I haven’t been able to find it, which is surprising since I never delete anything.
Very unfortunate for me………. What to do now ? Does anyone of the other participants have a copy of it ? If Bernie or Jim or anyone else has saved a copy of it, please request them on my behalf to provide a copy of it.
Thanks and Regards
Kanwaljit
Thank you so much. You will save me so much time.
I keep this in my custom add-in with a toolbar button to the TargetFinder macro. I basically took the code from the recursion model workbook posted in a prior comment out of the template worksheet and adapted it to work on whatever items you have selected at the moment. I find it very useful when trying to figure out what accounts were rolled up into a total account in financial statements. I wish I could understand Tushar’s code enough to set it up in a similar way. As it stands right now, I can barely run this against 22 numbers on a 2GHz Core2Duo rig before it’s too slow to bear.
Dim dblTarget As Double
Dim intElements As Integer
Dim intStat() As Integer
Dim intStatb() As Integer
Dim dblElements() As Double
Dim dblBest As Double
Dim rngInputCells() As Range
Sub StoreIt()
Dim intCount As Integer
Dim dblClosest As Double
Dim rngResult As Range
For intCount = 1 To intElements
If intStatb(intCount) = 1 Then
dblClosest = dblClosest + rngInputCells(intCount).Value
If rngResult Is Nothing Then
Set rngResult = rngInputCells(intCount)
Else
Set rngResult = Union(rngResult, rngInputCells(intCount))
End If
End If
Next intCount
If Not rngResult Is Nothing Then rngResult.Select
If dblClosest = 0 Then
MsgBox "An answer could not be found", vbInformation, "Unsolvable"
Else
If MsgBox("You searched for " & Format(dblTarget, "#,###.00") & "." & vbCrLf & "The closest answer is " & Format(dblClosest, "#,###.00") & "." & vbCrLf & vbCrLf & "Press Yes to highlight these in red." & vbCrLf & vbCrLf, vbInformation + vbYesNo, "Result") = vbYes Then
rngResult.Interior.ColorIndex = 3
End If
End If
End Sub
Sub CopyIt()
Dim intCount As Integer
For intCount = 1 To intElements
intStatb(intCount) = intStat(intCount)
Next intCount
End Sub
Sub Evaluate(ByVal total As Double, ByVal pos As Integer)
If pos 0 Then 'skip zeros
If Not dblElements(1) = 0 Then 'don't redim first time
ReDim Preserve dblElements(1 To UBound(dblElements) + 1)
ReDim Preserve rngInputCells(1 To UBound(rngInputCells) + 1)
End If
dblElements(UBound(dblElements)) = CDbl(rngCell.Value)
Set rngInputCells(UBound(rngInputCells)) = rngCell
End If
End If
Next
If UBound(dblElements) > 20 Then
If MsgBox("You selected " & UBound(dblElements) & " items. Anything over 20 may take a very long time to calculate. Are you sure you want to continue?", vbExclamation + vbYesNo, "Are you sure?") = vbNo Then Exit Sub
End If
ReDim intStat(1 To UBound(dblElements))
ReDim intStatb(1 To UBound(dblElements))
dblBest = 0
dblTarget = Application.InputBox("What is the Target amount?", "Target", Type:=1)
intElements = UBound(dblElements)
Evaluate 0, 1
StoreIt
End Sub
Hi,
When searching the internet for my ‘problem’, I found your emailchain that looks exactly what I was looking for. Never realized it would take so much time to come to sollutions for subsets larger than 25 items, I have sets of 100 items and larger… But I couldn’t find the Jim T sollution, I would love to have this code that will show all possible sollutions and not just one possible sollution. Dick Kusleika says it is posted on the intranet, but I cann’t find it back. Can you please send it to me?
By the way I love this excel forum! Realy good.
Thanks,
Leo
Could one of you guys contact me (matt.j.steele@gmail.com) about the recursion formulas shown in this blog. I am prepared to pay for a excel spreadsheet solution that involves multiple targets from a list of data, using each value in the data list only once. I would also like to receive a copy of the spreadsheet that Dick Kusleika said he would post on internet back in 2005. Thanks.-
leo, matthew steele: The more recent version of the webpage I linked to above now has a VBA routine that lists multiple combinations, each of which sums to the target value. See
Find a set of amounts that match a target value
http://www.tushar-mehta.com/excel/templates/match_values/index.html
question about a code
masinalogan@yahoo.co.uk
Dear Mr .
http://www.developerfood.com/re-how-to-get-all-number-combination-from-a-list/microsoft-public-excel-programming/fe274fbc-1e26-4385-863f-257eaa3a7b18/article.aspx
At this address i found a very nice code.
I put it on Excel and with macro it is working good.
But i want to find the solution at the next 2 problems.If you can , please teach me how to made the code.
For exemple before the code is running i want to make to appear a mesage like this
DO YOU WANT TO SHOW (DISPLAY) ALL COMBINATIONS OR JUST THE COMBINATIONS THAT CONTAIN NUMBER 1 ( or 77 or 84 etc)?
……………………………………………………..
Or another condition:
I want to write some arrays on the excel sheet:
array1 from AC5:DD5 first array
array2 from AC6:DD6 second.
array3 from AC7:DD7
array4 from AC8:DD8
…………………………………………………..
…………………………………………………………….
array n from ACn:DDn
Then i want a code that read one after another this arrays and take only m numbers
from an array.
So the combinations that apearrs must contain only m numbers from this arrays
array1 from AC5:DD5 first array
array2 from AC6:DD6 second.
array3 from AC7:DD7
array4 from AC8:DD8
…………………………………………………..
…………………………………………………………….
array n from ACn:DDn
If you can help me THANK YOU.
If you canot then i must surf the Web.
Thank you for your time and consideration.
Hi Mr. Logan
The above link is not working. Any Guess
The posted example can also be solved quickly without code…
In cell C1, ctrl+shift+enter:
=MIN(ABS(
INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^1)/2^0)*B3
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^2)/2^1)*B4
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^3)/2^2)*B5
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^4)/2^3)*B6
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^5)/2^4)*B7
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^6)/2^5)*B8
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^7)/2^6)*B9
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^8)/2^7)*B10
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^9)/2^8)*B11
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^10)/2^9)*B12
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^11)/2^10)*B13
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^12)/2^11)*B14
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^13)/2^12)*B15
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^14)/2^13)*B16
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^15)/2^14)*B17
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^16)/2^15)*B18
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^17)/2^16)*B19
+INT(MOD(ROW(B:B)+2^16*{0,1,2,3},2^18)/2^17)*B20
-B1)*100+(ROW(B:B)+2^16*{0,1,2,3})/10^6)
(or use row(b1:b262144) in xl2007). Now fill down from C3:
=INT(MOD(ROUND(10^6*MOD($C$1,1),0),2^A3)/2^A3*2)
For other solutions you can use SMALL(,k) in place of MIN().
1000 points to you.
I was presented the problem,
tried to solve it myself,
realized it would be difficult to code, (for me, at least)
found the name of the problem,
searched google,
and found you had already created the solver for me!
I’m thrilled, Thanks.
~Joe
Just downloaded Recursion1.zip and it works perfectly! It’s a little slow with 30 to 40 combinations but all told it’s a life saver. I don’t know about the rest of you but I will be using this when I reconcile my credit card deposits in QuickBooks Pro. For the last 2 years I’ve cussed QB for not having this built in. THANKS!