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.