Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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
Posted to microsoft.public.excel.misc
|
|||
|
|||
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 |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Please help - sorting list of numbers | Excel Worksheet Functions | |||
Counting groups of exact numbers in a huge list (column) | Excel Discussion (Misc queries) | |||
How to identify a list of numbers as a publisher field | Excel Discussion (Misc queries) | |||
find sum in list of of numbers | New Users to Excel | |||
How can I compare a number against a list of numbers | Excel Worksheet Functions |