Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Here's an interesting one.
Suspect it might require VBA, but it'll be more than just VBA. Let's say I have a figure that one system has spat out, but it's not clear how it's been arrived at. Another system might give a list of all possible components to this in a report which can be exported to Excel. I would want a tool to look through the list of all possible values and select only values which could be combined to make up the total that the other system spat out. Does this make sense? Is it something we could ever get a computer to do? Thoughts? |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
I think you would need to ensure the Philosophy or possibly the 20/20
foresight add-ins were installed. "mr tom" wrote: Here's an interesting one. Suspect it might require VBA, but it'll be more than just VBA. Let's say I have a figure that one system has spat out, but it's not clear how it's been arrived at. Another system might give a list of all possible components to this in a report which can be exported to Excel. I would want a tool to look through the list of all possible values and select only values which could be combined to make up the total that the other system spat out. Does this make sense? Is it something we could ever get a computer to do? Thoughts? |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Find numbers that add up to a specified sum.
Niek Otten 5-Apr-06 This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited set of data One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly, it will miss that combination. I don't know if this has been corrected later. Note the requirements for your settings documented in the code itself Peo's solution: ================================================== One way but you need the solver add-in installed (it comes with excel/office,check under toolsadd-ins) put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} in the adjacent cells in C2 put 8, in D2 put #VALUE! select D2 and do toolssolver, set target cell $D$2 (should come up automatically if selected) Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject to the constraints of: in Cell reference put $B$2:$B$7 from dropdown select Bin, click OK and click Solve, Keep solver solution and look at the table 2 1 4 0 5 0 6 1 9 0 13 0 there you can see that 4 ones have been replaced by zeros and the adjacent cells to the 2 ones total 8 -- Regards, Peo Sjoblom ================================================== Harlan's solution: 'Begin VBA Code ' By Harlan Grove Sub findsums() 'This *REQUIRES* VBAProject references to 'Microsoft Scripting Runtime 'Microsoft VBScript Regular Expressions 1.0 or higher Const TOL As Double = 0.000001 'modify as needed Dim c As Variant Dim j As Long, k As Long, n As Long, p As Boolean Dim s As String, t As Double, u As Double Dim v As Variant, x As Variant, y As Variant Dim dc1 As New Dictionary, dc2 As New Dictionary Dim dcn As Dictionary, dco As Dictionary Dim re As New RegExp re.Global = True re.IgnoreCase = True On Error Resume Next Set x = Application.InputBox( _ Prompt:="Enter range of values:", _ Title:="findsums", _ Default:="", _ Type:=8 _ ) If x Is Nothing Then Err.Clear Exit Sub End If y = Application.InputBox( _ Prompt:="Enter target value:", _ Title:="findsums", _ Default:="", _ Type:=1 _ ) If VarType(y) = vbBoolean Then Exit Sub Else t = y End If On Error GoTo 0 Set dco = dc1 Set dcn = dc2 Call recsoln For Each y In x.Value2 If VarType(y) = vbDouble Then If Abs(t - y) < TOL Then recsoln "+" & Format(y) ElseIf dco.Exists(y) Then dco(y) = dco(y) + 1 ElseIf y < t - TOL Then dco.Add Key:=y, Item:=1 c = CDec(c + 1) Application.StatusBar = "[1] " & Format(c) End If End If Next y n = dco.Count ReDim v(1 To n, 1 To 3) For k = 1 To n v(k, 1) = dco.Keys(k - 1) v(k, 2) = dco.Items(k - 1) Next k qsortd v, 1, n For k = n To 1 Step -1 v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) If v(k, 3) t Then dcn.Add Key:="+" & _ Format(v(k, 1)), Item:=v(k, 1) Next k On Error GoTo CleanUp Application.EnableEvents = False Application.Calculation = xlCalculationManual For k = 2 To n dco.RemoveAll swapo dco, dcn For Each y In dco.Keys p = False For j = 1 To n If v(j, 3) < t - dco(y) - TOL Then Exit For x = v(j, 1) s = "+" & Format(x) If Right(y, Len(s)) = s Then p = True If p Then re.Pattern = "\" & s & "(?=(\+|$))" If re.Execute(y).Count < v(j, 2) Then u = dco(y) + x If Abs(t - u) < TOL Then recsoln y & s ElseIf u < t - TOL Then dcn.Add Key:=y & s, Item:=u c = CDec(c + 1) Application.StatusBar = "[" & Format(k) & "] " & _ Format(c) End If End If End If Next j Next y If dcn.Count = 0 Then Exit For Next k If (recsoln() = 0) Then _ MsgBox Prompt:="all combinations exhausted", _ Title:="No Solution" CleanUp: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.StatusBar = False End Sub Private Function recsoln(Optional s As String) Const OUTPUTWSN As String = "findsums solutions" 'modify to taste Static r As Range Dim ws As Worksheet If s = "" And r Is Nothing Then On Error Resume Next Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) If ws Is Nothing Then Err.Clear Application.ScreenUpdating = False Set ws = ActiveSheet Set r = Worksheets.Add.Range("A1") r.Parent.Name = OUTPUTWSN ws.Activate Application.ScreenUpdating = False Else ws.Cells.Clear Set r = ws.Range("A1") End If recsoln = 0 ElseIf s = "" Then recsoln = r.Row - 1 Set r = Nothing Else r.Value = s Set r = r.Offset(1, 0) recsoln = r.Row - 1 End If End Function Private Sub qsortd(v As Variant, lft As Long, rgt As Long) 'ad hoc quicksort subroutine 'translated from Aho, Weinberger & Kernighan, '"The Awk Programming Language", page 161 Dim j As Long, pvt As Long If (lft = rgt) Then Exit Sub swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) pvt = lft For j = lft + 1 To rgt If v(j, 1) v(lft, 1) Then pvt = pvt + 1 swap2 v, pvt, j End If Next j swap2 v, lft, pvt qsortd v, lft, pvt - 1 qsortd v, pvt + 1, rgt End Sub Private Sub swap2(v As Variant, i As Long, j As Long) 'modified version of the swap procedure from 'translated from Aho, Weinberger & Kernighan, '"The Awk Programming Language", page 161 Dim t As Variant, k As Long For k = LBound(v, 2) To UBound(v, 2) t = v(i, k) v(i, k) = v(j, k) v(j, k) = t Next k End Sub Private Sub swapo(a As Object, b As Object) Dim t As Object Set t = a Set a = b Set b = t End Sub '---- end VBA code ---- -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Here's an interesting one. | | Suspect it might require VBA, but it'll be more than just VBA. | | Let's say I have a figure that one system has spat out, but it's not clear | how it's been arrived at. | | Another system might give a list of all possible components to this in a | report which can be exported to Excel. | | I would want a tool to look through the list of all possible values and | select only values which could be combined to make up the total that the | other system spat out. | | Does this make sense? | | Is it something we could ever get a computer to do? | | Thoughts? |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Agreed.
Unfortunately, it's a new job, I've gone somewhere where things "sort of evolved" and I need to make some sense of (and improve) it. Unless I can work out how stuff is made up, I'm stuck. An example list would be: 11.57 16.83 18.26 9.35 27.54 53 An example total would be: 90.75 I can apply logic and see that the total is made up from 11.57, 16.83, 9.35 and 53. Surely there's some way of getting a computer to do something similar. It might be some sort of iterative process. Thoughts? "Mike" wrote: I think you would need to ensure the Philosophy or possibly the 20/20 foresight add-ins were installed. "mr tom" wrote: Here's an interesting one. Suspect it might require VBA, but it'll be more than just VBA. Let's say I have a figure that one system has spat out, but it's not clear how it's been arrived at. Another system might give a list of all possible components to this in a report which can be exported to Excel. I would want a tool to look through the list of all possible values and select only values which could be combined to make up the total that the other system spat out. Does this make sense? Is it something we could ever get a computer to do? Thoughts? |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Looks good.
I'm looking at the solver add-in. I get an error message about how the target cell must contain a formula. Your post said D2 should be set to #VALUE! Alternatively, have I missed soemthing? Cheers, Tom. "Niek Otten" wrote: Find numbers that add up to a specified sum. Niek Otten 5-Apr-06 This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited set of data One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly, it will miss that combination. I don't know if this has been corrected later. Note the requirements for your settings documented in the code itself Peo's solution: ================================================== One way but you need the solver add-in installed (it comes with excel/office,check under toolsadd-ins) put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} in the adjacent cells in C2 put 8, in D2 put #VALUE! select D2 and do toolssolver, set target cell $D$2 (should come up automatically if selected) Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject to the constraints of: in Cell reference put $B$2:$B$7 from dropdown select Bin, click OK and click Solve, Keep solver solution and look at the table 2 1 4 0 5 0 6 1 9 0 13 0 there you can see that 4 ones have been replaced by zeros and the adjacent cells to the 2 ones total 8 -- Regards, Peo Sjoblom ================================================== Harlan's solution: 'Begin VBA Code ' By Harlan Grove Sub findsums() 'This *REQUIRES* VBAProject references to 'Microsoft Scripting Runtime 'Microsoft VBScript Regular Expressions 1.0 or higher Const TOL As Double = 0.000001 'modify as needed Dim c As Variant Dim j As Long, k As Long, n As Long, p As Boolean Dim s As String, t As Double, u As Double Dim v As Variant, x As Variant, y As Variant Dim dc1 As New Dictionary, dc2 As New Dictionary Dim dcn As Dictionary, dco As Dictionary Dim re As New RegExp re.Global = True re.IgnoreCase = True On Error Resume Next Set x = Application.InputBox( _ Prompt:="Enter range of values:", _ Title:="findsums", _ Default:="", _ Type:=8 _ ) If x Is Nothing Then Err.Clear Exit Sub End If y = Application.InputBox( _ Prompt:="Enter target value:", _ Title:="findsums", _ Default:="", _ Type:=1 _ ) If VarType(y) = vbBoolean Then Exit Sub Else t = y End If On Error GoTo 0 Set dco = dc1 Set dcn = dc2 Call recsoln For Each y In x.Value2 If VarType(y) = vbDouble Then If Abs(t - y) < TOL Then recsoln "+" & Format(y) ElseIf dco.Exists(y) Then dco(y) = dco(y) + 1 ElseIf y < t - TOL Then dco.Add Key:=y, Item:=1 c = CDec(c + 1) Application.StatusBar = "[1] " & Format(c) End If End If Next y n = dco.Count ReDim v(1 To n, 1 To 3) For k = 1 To n v(k, 1) = dco.Keys(k - 1) v(k, 2) = dco.Items(k - 1) Next k qsortd v, 1, n For k = n To 1 Step -1 v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) If v(k, 3) t Then dcn.Add Key:="+" & _ Format(v(k, 1)), Item:=v(k, 1) Next k On Error GoTo CleanUp Application.EnableEvents = False Application.Calculation = xlCalculationManual For k = 2 To n dco.RemoveAll swapo dco, dcn For Each y In dco.Keys p = False For j = 1 To n If v(j, 3) < t - dco(y) - TOL Then Exit For x = v(j, 1) s = "+" & Format(x) If Right(y, Len(s)) = s Then p = True If p Then re.Pattern = "\" & s & "(?=(\+|$))" If re.Execute(y).Count < v(j, 2) Then u = dco(y) + x If Abs(t - u) < TOL Then recsoln y & s ElseIf u < t - TOL Then dcn.Add Key:=y & s, Item:=u c = CDec(c + 1) Application.StatusBar = "[" & Format(k) & "] " & _ Format(c) End If End If End If Next j Next y If dcn.Count = 0 Then Exit For Next k If (recsoln() = 0) Then _ MsgBox Prompt:="all combinations exhausted", _ Title:="No Solution" CleanUp: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.StatusBar = False End Sub Private Function recsoln(Optional s As String) Const OUTPUTWSN As String = "findsums solutions" 'modify to taste Static r As Range Dim ws As Worksheet If s = "" And r Is Nothing Then On Error Resume Next Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) If ws Is Nothing Then Err.Clear Application.ScreenUpdating = False Set ws = ActiveSheet Set r = Worksheets.Add.Range("A1") r.Parent.Name = OUTPUTWSN ws.Activate Application.ScreenUpdating = False Else ws.Cells.Clear Set r = ws.Range("A1") End If recsoln = 0 ElseIf s = "" Then recsoln = r.Row - 1 Set r = Nothing Else r.Value = s Set r = r.Offset(1, 0) recsoln = r.Row - 1 End If End Function Private Sub qsortd(v As Variant, lft As Long, rgt As Long) 'ad hoc quicksort subroutine 'translated from Aho, Weinberger & Kernighan, '"The Awk Programming Language", page 161 Dim j As Long, pvt As Long If (lft = rgt) Then Exit Sub swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) pvt = lft For j = lft + 1 To rgt If v(j, 1) v(lft, 1) Then pvt = pvt + 1 swap2 v, pvt, j End If Next j swap2 v, lft, pvt qsortd v, lft, pvt - 1 qsortd v, pvt + 1, rgt End Sub Private Sub swap2(v As Variant, i As Long, j As Long) 'modified version of the swap procedure from 'translated from Aho, Weinberger & Kernighan, '"The Awk Programming Language", page 161 Dim t As Variant, k As Long For k = LBound(v, 2) To UBound(v, 2) t = v(i, k) v(i, k) = v(j, k) v(j, k) = t Next k End Sub Private Sub swapo(a As Object, b As Object) Dim t As Object Set t = a Set a = b Set b = t End Sub '---- end VBA code ---- -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Here's an interesting one. | | Suspect it might require VBA, but it'll be more than just VBA. | | Let's say I have a figure that one system has spat out, but it's not clear | how it's been arrived at. | | Another system might give a list of all possible components to this in a | report which can be exported to Excel. | | I would want a tool to look through the list of all possible values and | select only values which could be combined to make up the total that the | other system spat out. | | Does this make sense? | | Is it something we could ever get a computer to do? | | Thoughts? |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Sorry about that! D2 should be set to
=SUMPRODUCT(A2:A7,B2:B7) -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Looks good. | | I'm looking at the solver add-in. | | I get an error message about how the target cell must contain a formula. | | Your post said D2 should be set to #VALUE! | Alternatively, have I missed soemthing? | | Cheers, | | Tom. | | "Niek Otten" wrote: | | Find numbers that add up to a specified sum. | Niek Otten | 5-Apr-06 | | This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited | set of data | One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan | Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly, | it will miss that combination. I don't know if this has been corrected later. | Note the requirements for your settings documented in the code itself | | Peo's solution: | ================================================== | One way but you need the solver add-in installed (it comes with | excel/office,check under toolsadd-ins) | put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} | in the adjacent cells | in C2 put 8, in D2 put | #VALUE! | select D2 and do toolssolver, set target cell $D$2 (should come up | automatically if selected) | Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject | to the constraints of: | in Cell reference put | $B$2:$B$7 | from dropdown select Bin, click OK and click Solve, Keep solver solution | and look at the table | 2 1 | 4 0 | 5 0 | 6 1 | 9 0 | 13 0 | there you can see that 4 ones have been replaced by zeros and the adjacent | cells to the 2 ones | total 8 | -- | Regards, | Peo Sjoblom | ================================================== | Harlan's solution: | | | 'Begin VBA Code | | ' By Harlan Grove | | Sub findsums() | 'This *REQUIRES* VBAProject references to | 'Microsoft Scripting Runtime | 'Microsoft VBScript Regular Expressions 1.0 or higher | | Const TOL As Double = 0.000001 'modify as needed | Dim c As Variant | | Dim j As Long, k As Long, n As Long, p As Boolean | Dim s As String, t As Double, u As Double | Dim v As Variant, x As Variant, y As Variant | Dim dc1 As New Dictionary, dc2 As New Dictionary | Dim dcn As Dictionary, dco As Dictionary | Dim re As New RegExp | | re.Global = True | re.IgnoreCase = True | | On Error Resume Next | | Set x = Application.InputBox( _ | Prompt:="Enter range of values:", _ | Title:="findsums", _ | Default:="", _ | Type:=8 _ | ) | | If x Is Nothing Then | Err.Clear | Exit Sub | End If | | y = Application.InputBox( _ | Prompt:="Enter target value:", _ | Title:="findsums", _ | Default:="", _ | Type:=1 _ | ) | | If VarType(y) = vbBoolean Then | Exit Sub | Else | t = y | End If | | On Error GoTo 0 | | Set dco = dc1 | Set dcn = dc2 | | Call recsoln | | For Each y In x.Value2 | If VarType(y) = vbDouble Then | If Abs(t - y) < TOL Then | recsoln "+" & Format(y) | | ElseIf dco.Exists(y) Then | dco(y) = dco(y) + 1 | | ElseIf y < t - TOL Then | dco.Add Key:=y, Item:=1 | | c = CDec(c + 1) | Application.StatusBar = "[1] " & Format(c) | | End If | | End If | Next y | | n = dco.Count | | ReDim v(1 To n, 1 To 3) | | For k = 1 To n | v(k, 1) = dco.Keys(k - 1) | v(k, 2) = dco.Items(k - 1) | Next k | | qsortd v, 1, n | | For k = n To 1 Step -1 | v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) | If v(k, 3) t Then dcn.Add Key:="+" & _ | Format(v(k, 1)), Item:=v(k, 1) | Next k | | On Error GoTo CleanUp | Application.EnableEvents = False | Application.Calculation = xlCalculationManual | | For k = 2 To n | dco.RemoveAll | swapo dco, dcn | | For Each y In dco.Keys | p = False | | For j = 1 To n | If v(j, 3) < t - dco(y) - TOL Then Exit For | x = v(j, 1) | s = "+" & Format(x) | If Right(y, Len(s)) = s Then p = True | If p Then | re.Pattern = "\" & s & "(?=(\+|$))" | If re.Execute(y).Count < v(j, 2) Then | u = dco(y) + x | If Abs(t - u) < TOL Then | recsoln y & s | ElseIf u < t - TOL Then | dcn.Add Key:=y & s, Item:=u | c = CDec(c + 1) | Application.StatusBar = "[" & Format(k) & "] " & _ | Format(c) | End If | End If | End If | Next j | Next y | | If dcn.Count = 0 Then Exit For | Next k | | If (recsoln() = 0) Then _ | MsgBox Prompt:="all combinations exhausted", _ | Title:="No Solution" | | CleanUp: | Application.EnableEvents = True | Application.Calculation = xlCalculationAutomatic | Application.StatusBar = False | | End Sub | | Private Function recsoln(Optional s As String) | Const OUTPUTWSN As String = "findsums solutions" 'modify to taste | | Static r As Range | Dim ws As Worksheet | | If s = "" And r Is Nothing Then | On Error Resume Next | Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) | If ws Is Nothing Then | Err.Clear | Application.ScreenUpdating = False | Set ws = ActiveSheet | Set r = Worksheets.Add.Range("A1") | r.Parent.Name = OUTPUTWSN | ws.Activate | Application.ScreenUpdating = False | Else | ws.Cells.Clear | Set r = ws.Range("A1") | End If | recsoln = 0 | ElseIf s = "" Then | recsoln = r.Row - 1 | Set r = Nothing | Else | r.Value = s | Set r = r.Offset(1, 0) | recsoln = r.Row - 1 | End If | End Function | | Private Sub qsortd(v As Variant, lft As Long, rgt As Long) | 'ad hoc quicksort subroutine | 'translated from Aho, Weinberger & Kernighan, | '"The Awk Programming Language", page 161 | | Dim j As Long, pvt As Long | | If (lft = rgt) Then Exit Sub | swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) | pvt = lft | For j = lft + 1 To rgt | If v(j, 1) v(lft, 1) Then | pvt = pvt + 1 | swap2 v, pvt, j | End If | Next j | | swap2 v, lft, pvt | | qsortd v, lft, pvt - 1 | qsortd v, pvt + 1, rgt | End Sub | | Private Sub swap2(v As Variant, i As Long, j As Long) | 'modified version of the swap procedure from | 'translated from Aho, Weinberger & Kernighan, | '"The Awk Programming Language", page 161 | | Dim t As Variant, k As Long | | For k = LBound(v, 2) To UBound(v, 2) | t = v(i, k) | v(i, k) = v(j, k) | v(j, k) = t | Next k | End Sub | | Private Sub swapo(a As Object, b As Object) | Dim t As Object | | Set t = a | Set a = b | Set b = t | End Sub | '---- end VBA code ---- | | | -- | Kind regards, | | Niek Otten | Microsoft MVP - Excel | | | "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | | Here's an interesting one. | | | | Suspect it might require VBA, but it'll be more than just VBA. | | | | Let's say I have a figure that one system has spat out, but it's not clear | | how it's been arrived at. | | | | Another system might give a list of all possible components to this in a | | report which can be exported to Excel. | | | | I would want a tool to look through the list of all possible values and | | select only values which could be combined to make up the total that the | | other system spat out. | | | | Does this make sense? | | | | Is it something we could ever get a computer to do? | | | | Thoughts? | | | |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Wow. Thanks Niek.
That's a great solution. Just one question - what happens if there's more than one solution? Alternatively, is there a guide to this posted anywhere that I've missed? Cheers, Tom. "Niek Otten" wrote: Sorry about that! D2 should be set to =SUMPRODUCT(A2:A7,B2:B7) -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Looks good. | | I'm looking at the solver add-in. | | I get an error message about how the target cell must contain a formula. | | Your post said D2 should be set to #VALUE! | Alternatively, have I missed soemthing? | | Cheers, | | Tom. | | "Niek Otten" wrote: | | Find numbers that add up to a specified sum. | Niek Otten | 5-Apr-06 | | This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited | set of data | One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by Harlan | Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value exactly, | it will miss that combination. I don't know if this has been corrected later. | Note the requirements for your settings documented in the code itself | | Peo's solution: | ================================================== | One way but you need the solver add-in installed (it comes with | excel/office,check under toolsadd-ins) | put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} | in the adjacent cells | in C2 put 8, in D2 put | #VALUE! | select D2 and do toolssolver, set target cell $D$2 (should come up | automatically if selected) | Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject | to the constraints of: | in Cell reference put | $B$2:$B$7 | from dropdown select Bin, click OK and click Solve, Keep solver solution | and look at the table | 2 1 | 4 0 | 5 0 | 6 1 | 9 0 | 13 0 | there you can see that 4 ones have been replaced by zeros and the adjacent | cells to the 2 ones | total 8 | -- | Regards, | Peo Sjoblom | ================================================== | Harlan's solution: | | | 'Begin VBA Code | | ' By Harlan Grove | | Sub findsums() | 'This *REQUIRES* VBAProject references to | 'Microsoft Scripting Runtime | 'Microsoft VBScript Regular Expressions 1.0 or higher | | Const TOL As Double = 0.000001 'modify as needed | Dim c As Variant | | Dim j As Long, k As Long, n As Long, p As Boolean | Dim s As String, t As Double, u As Double | Dim v As Variant, x As Variant, y As Variant | Dim dc1 As New Dictionary, dc2 As New Dictionary | Dim dcn As Dictionary, dco As Dictionary | Dim re As New RegExp | | re.Global = True | re.IgnoreCase = True | | On Error Resume Next | | Set x = Application.InputBox( _ | Prompt:="Enter range of values:", _ | Title:="findsums", _ | Default:="", _ | Type:=8 _ | ) | | If x Is Nothing Then | Err.Clear | Exit Sub | End If | | y = Application.InputBox( _ | Prompt:="Enter target value:", _ | Title:="findsums", _ | Default:="", _ | Type:=1 _ | ) | | If VarType(y) = vbBoolean Then | Exit Sub | Else | t = y | End If | | On Error GoTo 0 | | Set dco = dc1 | Set dcn = dc2 | | Call recsoln | | For Each y In x.Value2 | If VarType(y) = vbDouble Then | If Abs(t - y) < TOL Then | recsoln "+" & Format(y) | | ElseIf dco.Exists(y) Then | dco(y) = dco(y) + 1 | | ElseIf y < t - TOL Then | dco.Add Key:=y, Item:=1 | | c = CDec(c + 1) | Application.StatusBar = "[1] " & Format(c) | | End If | | End If | Next y | | n = dco.Count | | ReDim v(1 To n, 1 To 3) | | For k = 1 To n | v(k, 1) = dco.Keys(k - 1) | v(k, 2) = dco.Items(k - 1) | Next k | | qsortd v, 1, n | | For k = n To 1 Step -1 | v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) | If v(k, 3) t Then dcn.Add Key:="+" & _ | Format(v(k, 1)), Item:=v(k, 1) | Next k | | On Error GoTo CleanUp | Application.EnableEvents = False | Application.Calculation = xlCalculationManual | | For k = 2 To n | dco.RemoveAll | swapo dco, dcn | | For Each y In dco.Keys | p = False | | For j = 1 To n | If v(j, 3) < t - dco(y) - TOL Then Exit For | x = v(j, 1) | s = "+" & Format(x) | If Right(y, Len(s)) = s Then p = True | If p Then | re.Pattern = "\" & s & "(?=(\+|$))" | If re.Execute(y).Count < v(j, 2) Then | u = dco(y) + x | If Abs(t - u) < TOL Then | recsoln y & s | ElseIf u < t - TOL Then | dcn.Add Key:=y & s, Item:=u | c = CDec(c + 1) | Application.StatusBar = "[" & Format(k) & "] " & _ | Format(c) | End If | End If | End If | Next j | Next y | | If dcn.Count = 0 Then Exit For | Next k | | If (recsoln() = 0) Then _ | MsgBox Prompt:="all combinations exhausted", _ | Title:="No Solution" | | CleanUp: | Application.EnableEvents = True | Application.Calculation = xlCalculationAutomatic | Application.StatusBar = False | | End Sub | | Private Function recsoln(Optional s As String) | Const OUTPUTWSN As String = "findsums solutions" 'modify to taste | | Static r As Range | Dim ws As Worksheet | | If s = "" And r Is Nothing Then | On Error Resume Next | Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) | If ws Is Nothing Then | Err.Clear | Application.ScreenUpdating = False | Set ws = ActiveSheet | Set r = Worksheets.Add.Range("A1") | r.Parent.Name = OUTPUTWSN | ws.Activate | Application.ScreenUpdating = False | Else | ws.Cells.Clear | Set r = ws.Range("A1") | End If | recsoln = 0 | ElseIf s = "" Then | recsoln = r.Row - 1 | Set r = Nothing | Else | r.Value = s | Set r = r.Offset(1, 0) | recsoln = r.Row - 1 | End If | End Function | | Private Sub qsortd(v As Variant, lft As Long, rgt As Long) | 'ad hoc quicksort subroutine | 'translated from Aho, Weinberger & Kernighan, | '"The Awk Programming Language", page 161 | | Dim j As Long, pvt As Long | | If (lft = rgt) Then Exit Sub | swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) | pvt = lft | For j = lft + 1 To rgt | If v(j, 1) v(lft, 1) Then | pvt = pvt + 1 | swap2 v, pvt, j | End If | Next j | | swap2 v, lft, pvt | | qsortd v, lft, pvt - 1 | qsortd v, pvt + 1, rgt | End Sub | | Private Sub swap2(v As Variant, i As Long, j As Long) | 'modified version of the swap procedure from | 'translated from Aho, Weinberger & Kernighan, | '"The Awk Programming Language", page 161 | | Dim t As Variant, k As Long | | For k = LBound(v, 2) To UBound(v, 2) | t = v(i, k) | v(i, k) = v(j, k) | v(j, k) = t | Next k | End Sub | | Private Sub swapo(a As Object, b As Object) | Dim t As Object | | Set t = a | Set a = b | Set b = t | End Sub | '---- end VBA code ---- | | | -- | Kind regards, | | Niek Otten | Microsoft MVP - Excel | | | "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | | Here's an interesting one. |
#8
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
AFAIK Solver stops when one solutions is found.
Harlan's solution finds all of them. -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Wow. Thanks Niek. | | That's a great solution. | | Just one question - what happens if there's more than one solution? | Alternatively, is there a guide to this posted anywhere that I've missed? | | Cheers, | | Tom. | | "Niek Otten" wrote: | | Sorry about that! D2 should be set to | | =SUMPRODUCT(A2:A7,B2:B7) | | | | -- | Kind regards, | | Niek Otten | Microsoft MVP - Excel | | "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | | Looks good. | | | | I'm looking at the solver add-in. | | | | I get an error message about how the target cell must contain a formula. | | | | Your post said D2 should be set to #VALUE! | | Alternatively, have I missed soemthing? | | | | Cheers, | | | | Tom. | | | | "Niek Otten" wrote: | | | | Find numbers that add up to a specified sum. | | Niek Otten | | 5-Apr-06 | | | | This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited | | set of data | | One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by | Harlan | | Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value | exactly, | | it will miss that combination. I don't know if this has been corrected later. | | Note the requirements for your settings documented in the code itself | | | | Peo's solution: | | ================================================== | | One way but you need the solver add-in installed (it comes with | | excel/office,check under toolsadd-ins) | | put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} | | in the adjacent cells | | in C2 put 8, in D2 put | | #VALUE! | | select D2 and do toolssolver, set target cell $D$2 (should come up | | automatically if selected) | | Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject | | to the constraints of: | | in Cell reference put | | $B$2:$B$7 | | from dropdown select Bin, click OK and click Solve, Keep solver solution | | and look at the table | | 2 1 | | 4 0 | | 5 0 | | 6 1 | | 9 0 | | 13 0 | | there you can see that 4 ones have been replaced by zeros and the adjacent | | cells to the 2 ones | | total 8 | | -- | | Regards, | | Peo Sjoblom | | ================================================== | | Harlan's solution: | | | | | | 'Begin VBA Code | | | | ' By Harlan Grove | | | | Sub findsums() | | 'This *REQUIRES* VBAProject references to | | 'Microsoft Scripting Runtime | | 'Microsoft VBScript Regular Expressions 1.0 or higher | | | | Const TOL As Double = 0.000001 'modify as needed | | Dim c As Variant | | | | Dim j As Long, k As Long, n As Long, p As Boolean | | Dim s As String, t As Double, u As Double | | Dim v As Variant, x As Variant, y As Variant | | Dim dc1 As New Dictionary, dc2 As New Dictionary | | Dim dcn As Dictionary, dco As Dictionary | | Dim re As New RegExp | | | | re.Global = True | | re.IgnoreCase = True | | | | On Error Resume Next | | | | Set x = Application.InputBox( _ | | Prompt:="Enter range of values:", _ | | Title:="findsums", _ | | Default:="", _ | | Type:=8 _ | | ) | | | | If x Is Nothing Then | | Err.Clear | | Exit Sub | | End If | | | | y = Application.InputBox( _ | | Prompt:="Enter target value:", _ | | Title:="findsums", _ | | Default:="", _ | | Type:=1 _ | | ) | | | | If VarType(y) = vbBoolean Then | | Exit Sub | | Else | | t = y | | End If | | | | On Error GoTo 0 | | | | Set dco = dc1 | | Set dcn = dc2 | | | | Call recsoln | | | | For Each y In x.Value2 | | If VarType(y) = vbDouble Then | | If Abs(t - y) < TOL Then | | recsoln "+" & Format(y) | | | | ElseIf dco.Exists(y) Then | | dco(y) = dco(y) + 1 | | | | ElseIf y < t - TOL Then | | dco.Add Key:=y, Item:=1 | | | | c = CDec(c + 1) | | Application.StatusBar = "[1] " & Format(c) | | | | End If | | | | End If | | Next y | | | | n = dco.Count | | | | ReDim v(1 To n, 1 To 3) | | | | For k = 1 To n | | v(k, 1) = dco.Keys(k - 1) | | v(k, 2) = dco.Items(k - 1) | | Next k | | | | qsortd v, 1, n | | | | For k = n To 1 Step -1 | | v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) | | If v(k, 3) t Then dcn.Add Key:="+" & _ | | Format(v(k, 1)), Item:=v(k, 1) | | Next k | | | | On Error GoTo CleanUp | | Application.EnableEvents = False | | Application.Calculation = xlCalculationManual | | | | For k = 2 To n | | dco.RemoveAll | | swapo dco, dcn | | | | For Each y In dco.Keys | | p = False | | | | For j = 1 To n | | If v(j, 3) < t - dco(y) - TOL Then Exit For | | x = v(j, 1) | | s = "+" & Format(x) | | If Right(y, Len(s)) = s Then p = True | | If p Then | | re.Pattern = "\" & s & "(?=(\+|$))" | | If re.Execute(y).Count < v(j, 2) Then | | u = dco(y) + x | | If Abs(t - u) < TOL Then | | recsoln y & s | | ElseIf u < t - TOL Then | | dcn.Add Key:=y & s, Item:=u | | c = CDec(c + 1) | | Application.StatusBar = "[" & Format(k) & "] " & _ | | Format(c) | | End If | | End If | | End If | | Next j | | Next y | | | | If dcn.Count = 0 Then Exit For | | Next k | | | | If (recsoln() = 0) Then _ | | MsgBox Prompt:="all combinations exhausted", _ | | Title:="No Solution" | | | | CleanUp: | | Application.EnableEvents = True | | Application.Calculation = xlCalculationAutomatic | | Application.StatusBar = False | | | | End Sub | | | | Private Function recsoln(Optional s As String) | | Const OUTPUTWSN As String = "findsums solutions" 'modify to taste | | | | Static r As Range | | Dim ws As Worksheet | | | | If s = "" And r Is Nothing Then | | On Error Resume Next | | Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) | | If ws Is Nothing Then | | Err.Clear | | Application.ScreenUpdating = False | | Set ws = ActiveSheet | | Set r = Worksheets.Add.Range("A1") | | r.Parent.Name = OUTPUTWSN | | ws.Activate | | Application.ScreenUpdating = False | | Else | | ws.Cells.Clear | | Set r = ws.Range("A1") | | End If | | recsoln = 0 | | ElseIf s = "" Then | | recsoln = r.Row - 1 | | Set r = Nothing | | Else | | r.Value = s | | Set r = r.Offset(1, 0) | | recsoln = r.Row - 1 | | End If | | End Function | | | | Private Sub qsortd(v As Variant, lft As Long, rgt As Long) | | 'ad hoc quicksort subroutine | | 'translated from Aho, Weinberger & Kernighan, | | '"The Awk Programming Language", page 161 | | | | Dim j As Long, pvt As Long | | | | If (lft = rgt) Then Exit Sub | | swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) | | pvt = lft | | For j = lft + 1 To rgt | | If v(j, 1) v(lft, 1) Then | | pvt = pvt + 1 | | swap2 v, pvt, j | | End If | | Next j | | | | swap2 v, lft, pvt | | | | qsortd v, lft, pvt - 1 | | qsortd v, pvt + 1, rgt | | End Sub | | | | Private Sub swap2(v As Variant, i As Long, j As Long) | | 'modified version of the swap procedure from | | 'translated from Aho, Weinberger & Kernighan, | | '"The Awk Programming Language", page 161 | | | | Dim t As Variant, k As Long | | | | For k = LBound(v, 2) To UBound(v, 2) | | t = v(i, k) | | v(i, k) = v(j, k) | | v(j, k) = t | | Next k | | End Sub | | | | Private Sub swapo(a As Object, b As Object) | | Dim t As Object | | | | Set t = a | | Set a = b | | Set b = t | | End Sub | | '---- end VBA code ---- | | | | | | -- | | Kind regards, | | | | Niek Otten | | Microsoft MVP - Excel | | | | | | "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | | | Here's an interesting one. |
#9
Posted to microsoft.public.excel.misc
|
|||
|
|||
Challenge - evaluate and select
Thank you.
I'll give the VBA thingy a look. Cheers, Tom. "Niek Otten" wrote: AFAIK Solver stops when one solutions is found. Harlan's solution finds all of them. -- Kind regards, Niek Otten Microsoft MVP - Excel "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | Wow. Thanks Niek. | | That's a great solution. | | Just one question - what happens if there's more than one solution? | Alternatively, is there a guide to this posted anywhere that I've missed? | | Cheers, | | Tom. | | "Niek Otten" wrote: | | Sorry about that! D2 should be set to | | =SUMPRODUCT(A2:A7,B2:B7) | | | | -- | Kind regards, | | Niek Otten | Microsoft MVP - Excel | | "mr tom" <mr-tom at mr-tom.co.uk.(donotspam) wrote in message ... | | Looks good. | | | | I'm looking at the solver add-in. | | | | I get an error message about how the target cell must contain a formula. | | | | Your post said D2 should be set to #VALUE! | | Alternatively, have I missed soemthing? | | | | Cheers, | | | | Tom. | | | | "Niek Otten" wrote: | | | | Find numbers that add up to a specified sum. | | Niek Otten | | 5-Apr-06 | | | | This type of application tends to be very resource-consuming. It is wise to test a solution first with a limited | | set of data | | One option is using Solver; I include an example given by MVP Peo Sjoblom. The other is a rather famous VBA Sub by | Harlan | | Grove. There seems to be one flaw: if the table is sorted ascending and the first n numbers sum up to the required value | exactly, | | it will miss that combination. I don't know if this has been corrected later. | | Note the requirements for your settings documented in the code itself | | | | Peo's solution: | | ================================================== | | One way but you need the solver add-in installed (it comes with | | excel/office,check under toolsadd-ins) | | put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc} | | in the adjacent cells | | in C2 put 8, in D2 put | | #VALUE! | | select D2 and do toolssolver, set target cell $D$2 (should come up | | automatically if selected) | | Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject | | to the constraints of: | | in Cell reference put | | $B$2:$B$7 | | from dropdown select Bin, click OK and click Solve, Keep solver solution | | and look at the table | | 2 1 | | 4 0 | | 5 0 | | 6 1 | | 9 0 | | 13 0 | | there you can see that 4 ones have been replaced by zeros and the adjacent | | cells to the 2 ones | | total 8 | | -- | | Regards, | | Peo Sjoblom | | ================================================== | | Harlan's solution: | | | | | | 'Begin VBA Code | | | | ' By Harlan Grove | | | | Sub findsums() | | 'This *REQUIRES* VBAProject references to | | 'Microsoft Scripting Runtime | | 'Microsoft VBScript Regular Expressions 1.0 or higher | | | | Const TOL As Double = 0.000001 'modify as needed | | Dim c As Variant | | | | Dim j As Long, k As Long, n As Long, p As Boolean | | Dim s As String, t As Double, u As Double | | Dim v As Variant, x As Variant, y As Variant | | Dim dc1 As New Dictionary, dc2 As New Dictionary | | Dim dcn As Dictionary, dco As Dictionary | | Dim re As New RegExp | | | | re.Global = True | | re.IgnoreCase = True | | | | On Error Resume Next | | | | Set x = Application.InputBox( _ | | Prompt:="Enter range of values:", _ | | Title:="findsums", _ | | Default:="", _ | | Type:=8 _ | | ) | | | | If x Is Nothing Then | | Err.Clear | | Exit Sub | | End If | | | | y = Application.InputBox( _ | | Prompt:="Enter target value:", _ | | Title:="findsums", _ | | Default:="", _ | | Type:=1 _ | | ) | | | | If VarType(y) = vbBoolean Then | | Exit Sub | | Else | | t = y | | End If | | | | On Error GoTo 0 | | | | Set dco = dc1 | | Set dcn = dc2 | | | | Call recsoln | | | | For Each y In x.Value2 | | If VarType(y) = vbDouble Then | | If Abs(t - y) < TOL Then | | recsoln "+" & Format(y) | | | | ElseIf dco.Exists(y) Then | | dco(y) = dco(y) + 1 | | | | ElseIf y < t - TOL Then | | dco.Add Key:=y, Item:=1 | | | | c = CDec(c + 1) | | Application.StatusBar = "[1] " & Format(c) | | | | End If | | | | End If | | Next y | | | | n = dco.Count | | | | ReDim v(1 To n, 1 To 3) | | | | For k = 1 To n | | v(k, 1) = dco.Keys(k - 1) | | v(k, 2) = dco.Items(k - 1) | | Next k | | | | qsortd v, 1, n | | | | For k = n To 1 Step -1 | | v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3) | | If v(k, 3) t Then dcn.Add Key:="+" & _ | | Format(v(k, 1)), Item:=v(k, 1) | | Next k | | | | On Error GoTo CleanUp | | Application.EnableEvents = False | | Application.Calculation = xlCalculationManual | | | | For k = 2 To n | | dco.RemoveAll | | swapo dco, dcn | | | | For Each y In dco.Keys | | p = False | | | | For j = 1 To n | | If v(j, 3) < t - dco(y) - TOL Then Exit For | | x = v(j, 1) | | s = "+" & Format(x) | | If Right(y, Len(s)) = s Then p = True | | If p Then | | re.Pattern = "\" & s & "(?=(\+|$))" | | If re.Execute(y).Count < v(j, 2) Then | | u = dco(y) + x | | If Abs(t - u) < TOL Then | | recsoln y & s | | ElseIf u < t - TOL Then | | dcn.Add Key:=y & s, Item:=u | | c = CDec(c + 1) | | Application.StatusBar = "[" & Format(k) & "] " & _ | | Format(c) | | End If | | End If | | End If | | Next j | | Next y | | | | If dcn.Count = 0 Then Exit For | | Next k | | | | If (recsoln() = 0) Then _ | | MsgBox Prompt:="all combinations exhausted", _ | | Title:="No Solution" | | | | CleanUp: | | Application.EnableEvents = True | | Application.Calculation = xlCalculationAutomatic | | Application.StatusBar = False | | | | End Sub | | | | Private Function recsoln(Optional s As String) | | Const OUTPUTWSN As String = "findsums solutions" 'modify to taste | | | | Static r As Range | | Dim ws As Worksheet | | | | If s = "" And r Is Nothing Then | | On Error Resume Next | | Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) | | If ws Is Nothing Then | | Err.Clear | | Application.ScreenUpdating = False | | Set ws = ActiveSheet | | Set r = Worksheets.Add.Range("A1") | | r.Parent.Name = OUTPUTWSN | | ws.Activate | | Application.ScreenUpdating = False | | Else | | ws.Cells.Clear | | Set r = ws.Range("A1") | | End If | | recsoln = 0 | | ElseIf s = "" Then | | recsoln = r.Row - 1 | | Set r = Nothing | | Else | | r.Value = s | | Set r = r.Offset(1, 0) | | recsoln = r.Row - 1 | | End If | | End Function | | | | Private Sub qsortd(v As Variant, lft As Long, rgt As Long) | | 'ad hoc quicksort subroutine | | 'translated from Aho, Weinberger & Kernighan, | | '"The Awk Programming Language", page 161 | | | | Dim j As Long, pvt As Long | | | | If (lft = rgt) Then Exit Sub | | swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) | | pvt = lft | | For j = lft + 1 To rgt | | If v(j, 1) v(lft, 1) Then | | pvt = pvt + 1 | | swap2 v, pvt, j | | End If | | Next j | | | | swap2 v, lft, pvt | | | | qsortd v, lft, pvt - 1 | | qsortd v, pvt + 1, rgt | | End Sub | | | | Private Sub swap2(v As Variant, i As Long, j As Long) | | 'modified version of the swap procedure from | | 'translated from Aho, Weinberger & Kernighan, | | '"The Awk Programming Language", page 161 | | | | Dim t As Variant, k As Long | | | | For k = LBound(v, 2) To UBound(v, 2) |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
evaluate #¡VALUE! and #!DIV/0! and other errors.... | Excel Worksheet Functions | |||
HOW to Evaluate a range with IF ? | Excel Discussion (Misc queries) | |||
Evaluate formula using VBA | Excel Discussion (Misc queries) | |||
evaluate HYPERLINK() | Excel Worksheet Functions | |||
EVALUATE Function | New Users to Excel |