Hi Gerry,
I think you can set the tolerance with the constant Tol
--
Kind regards,
Niek Otten
Microsoft MVP - Excel
| Harlan's macro is a very powerful piece of code, but can it be adjusted
to
| give the closest answer as if no exact match is found, it returns
nothing
| which is of little use in my scenario. As to the solver addin solution,
its
| far to slow to be of any practical use for lists over 25 items.
|
| Does Harlan have a website by any chance which explains the code in any
| detail as I might have a bash at adjusting it my self
|
| All help much appreciated.
|
|
|
| | > Hi Gerry,
| >
| > Copied from my archive
| >
| >
| > --
| > Kind regards,
| >
| > Niek Otten
| > Microsoft MVP - Excel
| >
| >
| > Find numbers that add up to a specified sum.
| > Niek Otten
| > 05-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
| > =SUMPRODUCT(A2:A7,B2:B7)
| > 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 ----
| >
| > | > |I have a list of several hundred policies each with a different
value.
| > | Occasionally I have a request to 'sell off' policies to a certain
value.
| > At
| > | the moment I manually select policies from the list till I get
'close
| > | enough' to the total. Is there a way of automating this and getting
the
| > | closest result possible?
| > |
| > | To put numbers to my problem above, suppose I have the following 9
| > policies
| > |
| > | 1 $11,234.67
| > | 2 $604.50
| > | 3 $7,632.00
| > | 4 $5,638.76
| > | 5 $16,345.98
| > | 6 $23,678.43
| > | 7 $15,678.44
| > | 8 $1,007.17
| > | 9 $53,713.97
| > |
| > | I get a request to sell of $54,500 worth, at a glance I would
probably
| > | select policies 8 & 9 (totaling $54,721.14), where as infact
policies 3,
| > 4,
| > | 5, 6 & 8 would be a better choice as they total $54,302.54
| > |
| > | All help would be much appreciated
| > |
| > | Gerry
| > |
| > |
| >
| >
|
|
