How much would I need?

m5rcc

New Member
Joined
Feb 15, 2013
Messages
16
Morning all,

I wonder if anyone can help for potentially a simple Excel solution.

I send a lot of items in the post and with the price increase by the Royal Mail I now need different stamps than before.

Is it possible to create a spreadsheet that would give me a solution to the question "How many stamps would I need to make.." whatever I need, whether it's £6.71 or £13.27 or £18.01.

There would most probably be no exact answer, so it could be say, one would need 4 x First, 3 x Second, 1 x 14p and there could be a few permutations to get the same answer, however, how do I go about creating such a spreadsheet?

The stamps I have are as follows:

0.53
0.62
0.76
0.93
1.28
1.72
2.03
6.4



Any help would be most welcome!

<colgroup><col></colgroup><tbody>
</tbody>
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

hippiehacker

Well-known Member
Joined
Aug 2, 2011
Messages
1,911
setup your spreadsheet as follow

AB
1stampsTotal Sum
20,5318,01
30,62
40,76
50,93
61,28
71,72
82,03
96,4

<tbody>
</tbody>


the following code needs 2 references
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

to set them navigate to tools -> references in VBA Editor

Code:
'Begin VBA Code

Sub find_combinations()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

Const TOL As Double = 0.01 '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 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
myarray = x

If Application.Sum(x) < Cells(2, 2) Then
 x.Copy Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
End If

If x Is Nothing Then
Err.Clear
Exit Sub
End If

y = Cells(2, 2)

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
 Cells(2, 2).Value = Cells(2, 2).Value + 0.01
 Call findsums
End If

CleanUp:


Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents

For i = LBound(myarray) To UBound(myarray)
 Cells(i + 1, 1).Value = myarray(i, 1)
Next


Application.Calculation = xlAutomatic
Application.MaxChange = 0.001
Application.StatusBar = False
Application.EnableEvents = True

End Sub

Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "Sheet1" '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
ws.Activate
Application.ScreenUpdating = False
Else
Range("C:C").ClearContents
Set r = ws.Range("C1")
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 ----

- run the find_combinations macro
- the combinations will be written to Column C
- if the total amount does not resolve in any combination the amount will be extended by 00.01 until any combination is found

this would be the result from above table

stampsTotal Sum+6,4+6,4+2,03+1,28+0,76+0,62+0,53
0,5318,02+6,4+6,4+1,72+1,72+0,62+0,62+0,53
0,62+6,4+6,4+1,72+1,28+0,93+0,76+0,53
0,76
0,93
1,28
1,72
2,03
6,4

<tbody>
</tbody>
 
Last edited:

m5rcc

New Member
Joined
Feb 15, 2013
Messages
16
setup your spreadsheet as follow

AB
1stampsTotal Sum
20,5318,01
30,62
40,76
50,93
61,28
71,72
82,03
96,4

<tbody>
</tbody>


the following code needs 2 references
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

to set them navigate to tools -> references in VBA Editor

Code:
'Begin VBA Code

Sub find_combinations()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher

Const TOL As Double = 0.01 '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 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
myarray = x

If Application.Sum(x) < Cells(2, 2) Then
 x.Copy Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1)
End If

If x Is Nothing Then
Err.Clear
Exit Sub
End If

y = Cells(2, 2)

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
 Cells(2, 2).Value = Cells(2, 2).Value + 0.01
 Call findsums
End If

CleanUp:


Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents

For i = LBound(myarray) To UBound(myarray)
 Cells(i + 1, 1).Value = myarray(i, 1)
Next


Application.Calculation = xlAutomatic
Application.MaxChange = 0.001
Application.StatusBar = False
Application.EnableEvents = True

End Sub

Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "Sheet1" '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
ws.Activate
Application.ScreenUpdating = False
Else
Range("C:C").ClearContents
Set r = ws.Range("C1")
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 ----

- run the find_combinations macro
- the combinations will be written to Column C
- if the total amount does not resolve in any combination the amount will be extended by 00.01 until any combination is found

this would be the result from above table

stampsTotal Sum+6,4+6,4+2,03+1,28+0,76+0,62+0,53
0,5318,02+6,4+6,4+1,72+1,72+0,62+0,62+0,53
0,62+6,4+6,4+1,72+1,28+0,93+0,76+0,53
0,76
0,93
1,28
1,72
2,03
6,4

<tbody>
</tbody>

Is VBA even necessary for this? I have no idea how that works (VBA that is...).

Running Excel 2013 so can't even see Tools!
 
Last edited:

m5rcc

New Member
Joined
Feb 15, 2013
Messages
16
Followed an Idiot's Guide, but I do get an error when running the macro:

"Compile error: Sub or Function not defined"
 

m5rcc

New Member
Joined
Feb 15, 2013
Messages
16
In Excel 2013, alt+f11 top open VB. Then tools>references and added the references required...

The "Compile error: Sub or Function not defined" relates to "Call findsums" on the code in:

If (recsoln() = 0) Then Cells(2, 2).Value = Cells(2, 2).Value + 0.01
Call findsums
End If
 

hippiehacker

Well-known Member
Joined
Aug 2, 2011
Messages
1,911
i see can you replace the

Code:
call findsum

with

Code:
Call find_combinations

I have modified a script which we use internally
 

m5rcc

New Member
Joined
Feb 15, 2013
Messages
16
i see can you replace the

Code:
call findsum

with

Code:
Call find_combinations

I have modified a script which we use internally

Thanks - done so, but all it seems to do is change the value of cell B2, i.e. the total sum.

I don't get anything in column C as your example had shown...
 

Forum statistics

Threads
1,176,670
Messages
5,904,378
Members
435,088
Latest member
Kingsof82

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top