Pick several numbers from a list to get as near as possible to required total

[GerryGerry]

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

[Niek Otten]

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 ----

"GerryGerry" <Ge...@Gerry.anon> wrote in message news:a_vBj.245063$LD6.2...@fe3.news.blueyonder.co.uk...

[Dana DeLouis]

> policies 3, 4, 5, 6 & 8 would be a better choice
> as they total $54,302.54

As a side note, I show the closest to 54,500 as being...

604.5 + 53713.97 =

54,318.47

--
Dana DeLouis

"GerryGerry" <Ge...@Gerry.anon> wrote in message
news:a_vBj.245063$LD6.2...@fe3.news.blueyonder.co.uk...

[GerryGerry]

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.

"Niek Otten" <nico...@xs4all.nl> wrote in message
news:%231rQlT4...@TK2MSFTNGP02.phx.gbl...

[Bernd P]

Hello Gerry,

I suggest to look here: http://michael-schwimmer.de/vba096.htm
and then to download: http://michael-schwimmer.de/download/Ergebnissuche.zip

It is a nice beautification of Mr. Excel's winning solution of his
challenge of the month (August 2002): http://www.mrexcel.com/pc09.shtml
and it comes with a tolerance parameter.

It is quite self-explanatory but it is in German. I have an English
translation if you need it.

Regards,
Bernd

[Niek Otten]

Hi Gerry,

I think you can set the tolerance with the constant Tol

--
Kind regards,

Niek Otten
Microsoft MVP - Excel

"GerryGerry" <Ge...@Gerry.anon> wrote in message news:FRyBj.245085$LD6.1...@fe3.news.blueyonder.co.uk...

[Niek Otten]

Hi Bernd,

That one is on my list (a nice compact one!) but not yet in my archive. I don't know why, but I had the idea there was some
discussion about this solution. Do you know anything about that? I may be wrong.
Unfortunately I don't have any application to use as a test case........

--
Kind regards,

Niek Otten
Microsoft MVP - Excel

"Bernd P" <bplu...@gmail.com> wrote in message news:7e9c80a7-fd99-4707...@d4g2000prg.googlegroups.com...

[Bernd P]

Hi Niek,

That VBA macro stops with the first fitting combination while Harlan's
approach will return all possible solutions.

Of course we could adjust both approaches to behave like the other
one...

Regards,
Bernd

[GerryGerry]

Thanks Niek that tolerance setting does the trick!

Regards

Gerry

"Niek Otten" <nico...@xs4all.nl> wrote in message

news:uJ6xay6g...@TK2MSFTNGP05.phx.gbl...

[O'Connell@discussions.microsoft.com Dan O'Connell]

I tried the solver method and I get the following error message: Too Many
Adjustable Cells - I am running MS Office 2007. Can't we do this through
Solver and not have to run any lengthy VB code?