Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 7
Default Finding a predetermined Sum from a List of Numbers

I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).

I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)

I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.

It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that would
automagically do the work for me.

Any thoughts?

  #2   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 5,441
Default Finding a predetermined Sum from a List of Numbers

Zach,

Harlan Grove's code has the best chance of finding your numbers, but note that it is extremely rare
to find just one solution, given the number of entries. You will need to copy the code into a
codemodule, and make the references noted at the top of the code. Your numbers should be in once
continous list, down a column, and (I think) sorted in ascending order. The predetermined sum can
be entered in a cell, or manually typed into the inputbox when prompted.

Then, run the macro FindSums, enter the ranges (or values), and cross your fingers.

HTH,
Bernie
MS Excel MVP


Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove

Sub FindSums()
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 ----





wrote in message
oups.com...
I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).

I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)

I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.

It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that would
automagically do the work for me.

Any thoughts?



  #3   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 7
Default Finding a predetermined Sum from a List of Numbers

Thanks for the help, but I think this is over my head. I put it in the
module, but I know very little about VBA, and I'm nto sure what the
references are of which you speak. If it's simple, could you explain?
If not, thanks anyway for your time.

- Z a c h


On Jan 16, 10:58 am, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,

Harlan Grove's code has the best chance of finding your numbers, but note that it is extremely rare
to find just one solution, given the number of entries. You will need to copy the code into a
codemodule, and make the references noted at the top of the code. Your numbers should be in once
continous list, down a column, and (I think) sorted in ascending order. The predetermined sum can
be entered in a cell, or manually typed into the inputbox when prompted.

Then, run the macro FindSums, enter the ranges (or values), and cross your fingers.

HTH,
Bernie
MS Excel MVP

Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove

Sub FindSums()
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 ----

wrote in ooglegroups.com...

I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).


I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)


I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.


It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that would
automagically do the work for me.


Any thoughts?


  #4   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 5,441
Default Finding a predetermined Sum from a List of Numbers

Zach,

References are pretty simple. When you are in the macro editor (actually called the Visual Basic
Editor - VBE), with the code showing, choose Tools / References... and find those two references in
the list, and put check boxes next to them.

If you have problems, contact me privately (take the spaces out, and change the dot to .) and I will
send you a working version, where you can copy your numbers into the workbook and click a shape to
run the macro.

HTH,
Bernie
MS Excel MVP


wrote in message
oups.com...
Thanks for the help, but I think this is over my head. I put it in the
module, but I know very little about VBA, and I'm nto sure what the
references are of which you speak. If it's simple, could you explain?
If not, thanks anyway for your time.

- Z a c h


On Jan 16, 10:58 am, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,

Harlan Grove's code has the best chance of finding your numbers, but note that it is extremely
rare
to find just one solution, given the number of entries. You will need to copy the code into a
codemodule, and make the references noted at the top of the code. Your numbers should be in once
continous list, down a column, and (I think) sorted in ascending order. The predetermined sum
can
be entered in a cell, or manually typed into the inputbox when prompted.

Then, run the macro FindSums, enter the ranges (or values), and cross your fingers.

HTH,
Bernie
MS Excel MVP

Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove

Sub FindSums()
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 ----

wrote in
ooglegroups.com...

I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).


I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)


I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.


It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that would
automagically do the work for me.


Any thoughts?




  #5   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 7
Default Finding a predetermined Sum from a List of Numbers

Woot.

OK, thanks a TON. That was in fact very simple. I feel stupid now,
but I guess that just goes to show you how little VB I know.

So, for anyone else that ever comes across this discussion, let me tell
you about this thing.

You need to pare down the possible numbers. With a list of around 60,
the thing ran and ran (I think I left it 10-15 minutes) before finally
locking up.

I went back, looked through my list, and combined a few I *knew* should
be grouped together. I got my list down to about 35. It only ran for
a few seconds and spat out about four different combinations that were
possible. Looking through them, I figured out pretty quickly which one
was the correct solution the person before me had done.

Thanks again, Bernie.

On Jan 16, 12:09 pm, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,

References are pretty simple. When you are in the macro editor (actually called the Visual Basic
Editor - VBE), with the code showing, choose Tools / References... and find those two references in
the list, and put check boxes next to them.

If you have problems, contact me privately (take the spaces out, and change the dot to .) and I will
send you a working version, where you can copy your numbers into the workbook and click a shape to
run the macro.

HTH,
Bernie
MS Excel MVP

wrote in ooglegroups.com...

Thanks for the help, but I think this is over my head. I put it in the
module, but I know very little about VBA, and I'm nto sure what the
references are of which you speak. If it's simple, could you explain?
If not, thanks anyway for your time.


- Z a c h


On Jan 16, 10:58 am, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,


Harlan Grove's code has the best chance of finding your numbers, but note that it is extremely
rare
to find just one solution, given the number of entries. You will need to copy the code into a
codemodule, and make the references noted at the top of the code. Your numbers should be in once
continous list, down a column, and (I think) sorted in ascending order. The predetermined sum
can
be entered in a cell, or manually typed into the inputbox when prompted.


Then, run the macro FindSums, enter the ranges (or values), and cross your fingers.


HTH,
Bernie
MS Excel MVP


Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove


Sub FindSums()
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 ----


wrote in
ooglegroups.com...


I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).


I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)


I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.


It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that would
automagically do the work for me.


Any thoughts?




  #6   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
 
Posts: 5,441
Default Finding a predetermined Sum from a List of Numbers

Zach,

Great! I was kicking myself for not noting that with 60 or so numbers, the
code may take a looooong time to find an answer, or that your machine may
run out of available memory before it converges.

Glad that you realized that by yourself...;-)

Bernie


wrote in message
ups.com...
Woot.

OK, thanks a TON. That was in fact very simple. I feel stupid now,
but I guess that just goes to show you how little VB I know.

So, for anyone else that ever comes across this discussion, let me tell
you about this thing.

You need to pare down the possible numbers. With a list of around 60,
the thing ran and ran (I think I left it 10-15 minutes) before finally
locking up.

I went back, looked through my list, and combined a few I *knew* should
be grouped together. I got my list down to about 35. It only ran for
a few seconds and spat out about four different combinations that were
possible. Looking through them, I figured out pretty quickly which one
was the correct solution the person before me had done.

Thanks again, Bernie.

On Jan 16, 12:09 pm, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,

References are pretty simple. When you are in the macro editor (actually
called the Visual Basic
Editor - VBE), with the code showing, choose Tools / References... and
find those two references in
the list, and put check boxes next to them.

If you have problems, contact me privately (take the spaces out, and
change the dot to .) and I will
send you a working version, where you can copy your numbers into the
workbook and click a shape to
run the macro.

HTH,
Bernie
MS Excel MVP

wrote in
ooglegroups.com...

Thanks for the help, but I think this is over my head. I put it in the
module, but I know very little about VBA, and I'm nto sure what the
references are of which you speak. If it's simple, could you explain?
If not, thanks anyway for your time.


- Z a c h


On Jan 16, 10:58 am, "Bernie Deitrick" <deitbe @ consumer dot org
wrote:
Zach,


Harlan Grove's code has the best chance of finding your numbers, but
note that it is extremely
rare
to find just one solution, given the number of entries. You will need
to copy the code into a
codemodule, and make the references noted at the top of the code.
Your numbers should be in once
continous list, down a column, and (I think) sorted in ascending
order. The predetermined sum
can
be entered in a cell, or manually typed into the inputbox when
prompted.


Then, run the macro FindSums, enter the ranges (or values), and cross
your fingers.


HTH,
Bernie
MS Excel MVP


Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove


Sub FindSums()
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 ----


wrote in
ooglegroups.com...


I'm in an odd situation, due to some office mishaps that no one
probably wants to hear about (and I'm cleaning up, but that's life).


I have a list of numbers. Let's say 5, 9, 3, 7, 2, and 4 for an
example. (Actually, they're dollar amounts, but you get the idea.)


I need some way to find out what combination of them toal X (say, in
this example, 16) so we can backtrack some work that was lost.


It doesn't even really need to be done natively in excel, if someone
happened to know a stand-alone program that I could just imput them
into. I've got about 60 entries, so enough to make working out the
total really difficult, if not nigh impossible, but not so difficult
that I couldn't just re-enter them into some sort of program that
would
automagically do the work for me.


Any thoughts?




Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Please help - sorting list of numbers ivoryblue1 Excel Worksheet Functions 2 August 16th 06 05:53 PM
Counting groups of exact numbers in a huge list (column) pgiessler Excel Discussion (Misc queries) 1 August 16th 06 05:00 PM
How to identify a list of numbers as a publisher field mmcdowell Excel Discussion (Misc queries) 1 March 17th 06 10:25 AM
find sum in list of of numbers Jim Thomlinson New Users to Excel 5 January 4th 06 08:07 PM
How can I compare a number against a list of numbers johnny Excel Worksheet Functions 4 March 22nd 05 08:13 PM


All times are GMT +1. The time now is 01:21 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"