find all combinations of cells that add up to certain number

[Guest]

Hi there,

I work in accounting and we're trying to tie numbers very often. I would
like to know of a possible function or code that can output all possible
combinations of cells in a column in an Excel Worksheet that add up to a
certain number I enter in the adjacent column. This will help me narrow down
to the possible combinations of numbers that add up to the number I am
researching.

Any help would greatly be appreciated.

Thanks,
AD!

 

[Niek Otten]

This has been covered often.
Use Google's Group search, using "permutations" as keyword in "*excel*"
groups
Be warned in advance: over 10-15 combinations will bring your computer to a
halt

http://groups.google.com/advanced_group_search

 

[Guest]

Give this link a look. Dick posted a spreadsheet that I modified that should
do the trick for you... Look for Combined Total... There is a download
avaliable.

http://www.dicks-blog.com/

 

[Tom Ogilvy]

Re: find all combinations of cells that add up to certain number

Code by Harlan Grove, recently posted by Bernie Deitrick:
======================
p,

Copy the code below (written by Harlan Grove) 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.

HTH,
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) < 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 ----

 

[Tom Ogilvy]

Think you will find that Harlan Grove's code is hard to beat.

By-the-way, you link is just to the top level of the blog. No hint of where
your file is located.

 

[Guest]

The link is right on the main page... Nov 7th post 3/4 the way down the page.
The code I am using is originally from Bernie.

 

[Guest]

Wow... Harlan's code is a lot faster than mine... I will have to look at it a
little more closely. That is impressive.
--
HTH...

Jim Thomlinson

Re: find all combinations of cells that add up to certain number

Code by Harlan Grove, recently posted by Bernie Deitrick:
======================
p,

Copy the code below (written by Harlan Grove) 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.

HTH,
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) < 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 ----


--
Regards,
Tom Ogilvy

Hi there,

I work in accounting and we're trying to tie numbers very often. I would
like to know of a possible function or code that can output all possible
combinations of cells in a column in an Excel Worksheet that add up to a
certain number I enter in the adjacent column. This will help me narrow down
to the possible combinations of numbers that add up to the number I am
researching.

Any help would greatly be appreciated.

Thanks,
AD!

 

[Tom Ogilvy]

You need to try Harlans code. First, the code Bernie posted in the
original thread on the blog was incomplete. Second, you stated it only
showed the last solution. In fact this code creates a new sheet and writes
all the solutions in that sheet. It took less than 2 seconds to do them
all vice the code you have plodding along whining to quit <g>.

 

[Guest]

I think Bernie was originally holding out on me. He sent me some code created
by someone other than Harlan (long time ago). It works but it is a bunch
slower.

(Similar to the guy who modified it. I work but a bunch slower. Maybe that
is why he sent me that code...) ;-)

Now to figure out what Harlan's code is up to... cause it is bunches faster.
Maybe now my code will not have to plod and whine (much like it's author).
Thanks Tom.

 

[Guest]

Tom, I apologize for my limited knowledge of programming, but when I run the
Macro, it gives an error message: "User defined type not defined" and points
to ---dc1 As New Dictionary---. Please let me know how I can get around
that, and any other such roadbloacks.

Thanks,
AD

Re: find all combinations of cells that add up to certain number

Code by Harlan Grove, recently posted by Bernie Deitrick:
======================
p,

Copy the code below (written by Harlan Grove) 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.

HTH,
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) < 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 ----


--
Regards,
Tom Ogilvy

Hi there,

I work in accounting and we're trying to tie numbers very often. I would
like to know of a possible function or code that can output all possible
combinations of cells in a column in an Excel Worksheet that add up to a
certain number I enter in the adjacent column. This will help me narrow down
to the possible combinations of numbers that add up to the number I am
researching.

Any help would greatly be appreciated.

Thanks,
AD!

 

[Guest]

Commented right at the top of the code it lists two required references. In
the VB editor, select Tools -> References -> and check off the two required
references... That should clean up the error...
--
HTH...

Jim Thomlinson

Tom, I apologize for my limited knowledge of programming, but when I run the
Macro, it gives an error message: "User defined type not defined" and points
to ---dc1 As New Dictionary---. Please let me know how I can get around
that, and any other such roadbloacks.

Thanks,
AD

Re: find all combinations of cells that add up to certain number

Code by Harlan Grove, recently posted by Bernie Deitrick:
======================
p,

Copy the code below (written by Harlan Grove) 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.

HTH,
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) < 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 ----


--
Regards,
Tom Ogilvy

Hi there,

I work in accounting and we're trying to tie numbers very often. I would
like to know of a possible function or code that can output all possible
combinations of cells in a column in an Excel Worksheet that add up to a
certain number I enter in the adjacent column. This will help me narrow down
to the possible combinations of numbers that add up to the number I am
researching.

Any help would greatly be appreciated.

Thanks,
AD!

 

[Guest]

Thanks Jim,

That is nice to know. Like I mentioned - my knowledge of programming is
very limited, so I was unaware of the process to include references.

Thanks very much for your quick responses!

AD

Commented right at the top of the code it lists two required references. In
the VB editor, select Tools -> References -> and check off the two required
references... That should clean up the error...
--
HTH...

Jim Thomlinson

Tom, I apologize for my limited knowledge of programming, but when I run the
Macro, it gives an error message: "User defined type not defined" and points
to ---dc1 As New Dictionary---. Please let me know how I can get around
that, and any other such roadbloacks.

Thanks,
AD

Re: find all combinations of cells that add up to certain number

Code by Harlan Grove, recently posted by Bernie Deitrick:
======================
p,

Copy the code below (written by Harlan Grove) 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.

HTH,
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) < 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 ----


--
Regards,
Tom Ogilvy



Hi there,

I work in accounting and we're trying to tie numbers very often. I would
like to know of a possible function or code that can output all possible
combinations of cells in a column in an Excel Worksheet that add up to a
certain number I enter in the adjacent column. This will help me narrow
down
to the possible combinations of numbers that add up to the number I am
researching.

Any help would greatly be appreciated.

Thanks,
AD!

 

[Harlan Grove]

AD wrote...

Tom, I apologize for my limited knowledge of programming, but when I run the
Macro, it gives an error message: "User defined type not defined" and points
to ---dc1 As New Dictionary---. Please let me know how I can get around
that, and any other such roadbloacks.

You didn't set the required references. See the top comments in the
code.

This isn't optional.

Note that this approach depends on VBA6, so Excel 2000 or more recent
(and won't work on Macs). If you're running Excel 97, you'll need to
change the declarations of all the Dictionary and RegExp objects to
Object type (and drop the 'New' tokens too), then include the following
code just after the declarations in findsums.

Set dc1 = CreateObject("Scripting.Dictionary")
Set dc2 = CreateObject("Scripting.Dictionary")
Set re = CreateObject("VBScript.RegExp")

 

[Guest]

Very nice code... Thanks for sharing. I now see where it is much faster than
the old code that I had. By sorting the values you stop searching as soon as
the combinations start to exceed the target (near as I can figure it). My
hats off to you.

 

[Dana DeLouis]

Hi. I think that w/ Harlan's excellent code, if the first 'n' numbers in
your list happen to sum to the desired total, then it will miss that
combination. I'm pretty sure it's the only one missed though. It is an
excellent code.