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 tools>add-ins)
| > | > put the data set in let's say A2:A8, in B2:B8 put a set of ones {1,1,1 etc}
| > | > in the adjacent cells
| > | > in C2 put 8, in D2 put
| > | > #VALUE!
| > | > select D2 and do tools>solver, set target cell $D$2 (should come up
| > | > automatically if selected)
| > | > Equal to a Value of 8, by changing cells $B$2:$B$7, click add under Subject
| > | > to the constraints of:
| > | > in Cell reference put
| > | > $B$2:$B$7
| > | > from dropdown select Bin, click OK and click Solve, Keep solver solution
| > | > and look at the table
| > | > 2 1
| > | > 4 0
| > | > 5 0
| > | > 6 1
| > | > 9 0
| > | > 13 0
| > | > there you can see that 4 ones have been replaced by zeros and the adjacent
| > | > cells to the 2 ones
| > | > total 8
| > | > --
| > | > Regards,
| > | > Peo Sjoblom
| > | > ==================================================
| > | > Harlan's solution:
| > | >
| > | >
| > | > 'Begin VBA Code
| > | >
| > | > ' By Harlan Grove
| > | >
| > | > Sub findsums()
| > | > 'This *REQUIRES* VBAProject references to
| > | > 'Microsoft Scripting Runtime
| > | > 'Microsoft VBScript Regular Expressions 1.0 or higher
| > | >
| > | > Const TOL As Double = 0.000001 'modify as needed
| > | > Dim c As Variant
| > | >
| > | > Dim j As Long, k As Long, n As Long, p As Boolean
| > | > Dim s As String, t As Double, u As Double
| > | > Dim v As Variant, x As Variant, y As Variant
| > | > Dim dc1 As New Dictionary, dc2 As New Dictionary
| > | > Dim dcn As Dictionary, dco As Dictionary
| > | > Dim re As New RegExp
| > | >
| > | > re.Global = True
| > | > re.IgnoreCase = True
| > | >
| > | > On Error Resume Next
| > | >
| > | > Set x = Application.InputBox( _
| > | > Prompt:="Enter range of values:", _
| > | > Title:="findsums", _
| > | > Default:="", _
| > | > Type:=8 _
| > | > )
| > | >
| > | > If x Is Nothing Then
| > | > Err.Clear
| > | > Exit Sub
| > | > End If
| > | >
| > | > y = Application.InputBox( _
| > | > Prompt:="Enter target value:", _
| > | > Title:="findsums", _
| > | > Default:="", _
| > | > Type:=1 _
| > | > )
| > | >
| > | > If VarType(y) = vbBoolean Then
| > | > Exit Sub
| > | > Else
| > | > t = y
| > | > End If
| > | >
| > | > On Error GoTo 0
| > | >
| > | > Set dco = dc1
| > | > Set dcn = dc2
| > | >
| > | > Call recsoln
| > | >
| > | > For Each y In x.Value2
| > | > If VarType(y) = vbDouble Then
| > | > If Abs(t - y) < TOL Then
| > | > recsoln "+" & Format(y)
| > | >
| > | > ElseIf dco.Exists(y) Then
| > | > dco(y) = dco(y) + 1
| > | >
| > | > ElseIf y < t - TOL Then
| > | > dco.Add Key:=y, Item:=1
| > | >
| > | > c = CDec(c + 1)
| > | > Application.StatusBar = "[1] " & Format(c)
| > | >
| > | > End If
| > | >
| > | > End If
| > | > Next y
| > | >
| > | > n = dco.Count
| > | >
| > | > ReDim v(1 To n, 1 To 3)
| > | >
| > | > For k = 1 To n
| > | > v(k, 1) = dco.Keys(k - 1)
| > | > v(k, 2) = dco.Items(k - 1)
| > | > Next k
| > | >
| > | > qsortd v, 1, n
| > | >
| > | > For k = n To 1 Step -1
| > | > v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
| > | > If v(k, 3) > t Then dcn.Add Key:="+" & _
| > | > Format(v(k, 1)), Item:=v(k, 1)
| > | > Next k
| > | >
| > | > On Error GoTo CleanUp
| > | > Application.EnableEvents = False
| > | > Application.Calculation = xlCalculationManual
| > | >
| > | > For k = 2 To n
| > | > dco.RemoveAll
| > | > swapo dco, dcn
| > | >
| > | > For Each y In dco.Keys
| > | > p = False
| > | >
| > | > For j = 1 To n
| > | > If v(j, 3) < t - dco(y) - TOL Then Exit For
| > | > x = v(j, 1)
| > | > s = "+" & Format(x)
| > | > If Right(y, Len(s)) = s Then p = True
| > | > If p Then
| > | > re.Pattern = "\" & s & "(?=(\+|$))"
| > | > If re.Execute(y).Count < v(j, 2) Then
| > | > u = dco(y) + x
| > | > If Abs(t - u) < TOL Then
| > | > recsoln y & s
| > | > ElseIf u < t - TOL Then
| > | > dcn.Add Key:=y & s, Item:=u
| > | > c = CDec(c + 1)
| > | > Application.StatusBar = "[" & Format(k) & "] " & _
| > | > Format(c)
| > | > End If
| > | > End If
| > | > End If
| > | > Next j
| > | > Next y
| > | >
| > | > If dcn.Count = 0 Then Exit For
| > | > Next k
| > | >
| > | > If (recsoln() = 0) Then _
| > | > MsgBox Prompt:="all combinations exhausted", _
| > | > Title:="No Solution"
| > | >
| > | > CleanUp:
| > | > Application.EnableEvents = True
| > | > Application.Calculation = xlCalculationAutomatic
| > | > Application.StatusBar = False
| > | >
| > | > End Sub
| > | >
| > | > Private Function recsoln(Optional s As String)
| > | > Const OUTPUTWSN As String = "findsums solutions" 'modify to taste
| > | >
| > | > Static r As Range
| > | > Dim ws As Worksheet
| > | >
| > | > If s = "" And r Is Nothing Then
| > | > On Error Resume Next
| > | > Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
| > | > If ws Is Nothing Then
| > | > Err.Clear
| > | > Application.ScreenUpdating = False
| > | > Set ws = ActiveSheet
| > | > Set r = Worksheets.Add.Range("A1")
| > | > r.Parent.Name = OUTPUTWSN
| > | > ws.Activate
| > | > Application.ScreenUpdating = False
| > | > Else
| > | > ws.Cells.Clear
| > | > Set r = ws.Range("A1")
| > | > End If
| > | > recsoln = 0
| > | > ElseIf s = "" Then
| > | > recsoln = r.Row - 1
| > | > Set r = Nothing
| > | > Else
| > | > r.Value = s
| > | > Set r = r.Offset(1, 0)
| > | > recsoln = r.Row - 1
| > | > End If
| > | > End Function
| > | >
| > | > Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
| > | > 'ad hoc quicksort subroutine
| > | > 'translated from Aho, Weinberger & Kernighan,
| > | > '"The Awk Programming Language", page 161
| > | >
| > | > Dim j As Long, pvt As Long
| > | >
| > | > If (lft >= rgt) Then Exit Sub
| > | > swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
| > | > pvt = lft
| > | > For j = lft + 1 To rgt
| > | > If v(j, 1) > v(lft, 1) Then
| > | > pvt = pvt + 1
| > | > swap2 v, pvt, j
| > | > End If
| > | > Next j
| > | >
| > | > swap2 v, lft, pvt
| > | >
| > | > qsortd v, lft, pvt - 1
| > | > qsortd v, pvt + 1, rgt
| > | > End Sub
| > | >
| > | > Private Sub swap2(v As Variant, i As Long, j As Long)
| > | > 'modified version of the swap procedure from
| > | > 'translated from Aho, Weinberger & Kernighan,
| > | > '"The Awk Programming Language", page 161
| > | >
| > | > Dim t As Variant, k As Long
| > | >
| > | > For k = LBound(v, 2) To UBound(v, 2)
| > | > t = v(i, k)
| > | > v(i, k) = v(j, k)
| > | > v(j, k) = t
| > | > Next k
| > | > End Sub
| > | >
| > | > Private Sub swapo(a As Object, b As Object)
| > | > Dim t As Object
| > | >
| > | > Set t = a
| > | > Set a = b
| > | > Set b = t
| > | > End Sub
| > | > '---- end VBA code ----
| > | >
| > | >
| > | > --
| > | > 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.
