Find numbers that add up to a specified sum.
Niek Otten
5-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 tools>add-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
#VALUE!
select D2 and do tools>solver, 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 ----
==================================================
================================================
Pasting a User Defined Function (UDF)
Niek Otten, March 31, 2006
If you find a VBA function on the Internet or somebody mails you one, and you don't know how to implement it, follow
these steps:
Select all the text of the function.
CTRL+C (that is, press and hold down the CTRL key, press C, release both). This a shortcut for Copy.
Go to Excel. Press ALT+F11 (same method: press and hold the ALT key, press the F11 key and release both). You are now
in the Visual Basic Editor (VBE).
From the menu bar, choose Insert>Module. There should now be a blank module sheet in front of you. Click in it and
then press CTRL+V (same method.). This a shortcut for Paste. You should now see the text of the function in the Module.
Press ALT+F11 again to return to your Excel worksheet.
You should now be able to use the function as if it were a built-in function of Excel, like =SUM(..)
================================================
--
Kind regards,
Niek Otten
Microsoft MVP - Excel
| Hello Friends,
|
| I need some assistance in solving a problem. I have a spreadsheet with
| over five hundred lines of transactions. The sum of these transactions
| are creating a balance on the account. Is there any formula/macro that
| will help me find the transactions creating the balance? The sum of the
| account should be zero. To clarify, if we owe client money, there
| would be a transaction setting up that postive balance then a payment
| on the account taking it back to zero. There could be multiple
| transactions and then one net payment. Or we could be due to receive.
| So at the end of the day, the account should be zero. I need to locate
| the transactions that are creating the balance (each line is a
| transaction). I need a function to cycle through the cells to try and
| identify possible entries that could cause the specific deviation. It
| could be a single entry that equals the deviation, or it could be 5
| separate cells that when summed up equal the deviation. I would need to
| setup the depth of the search, and then construct a table of all of the
| possible solutions. Anyone know how I can do this?
|
