How much would I need?

M

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:

[TABLE="width: 35"]
<colgroup><col></colgroup><tbody>[TR]
[TD="align: right"]0.53[/TD]
[/TR]
[TR]
[TD="align: right"]0.62[/TD]
[/TR]
[TR]
[TD="align: right"]0.76[/TD]
[/TR]
[TR]
[TD="align: right"]0.93[/TD]
[/TR]
[TR]
[TD="align: right"]1.28[/TD]
[/TR]
[TR]
[TD="align: right"]1.72[/TD]
[/TR]
[TR]
[TD="align: right"]2.03[/TD]
[/TR]
[TR]
[TD="align: right"]6.4


[/TD]
[/TR]
[TR]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: right"]
Any help would be most welcome![/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
setup your spreadsheet as follow

[TABLE="class: grid, width: 182, align: center"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]stamps[/TD]
[TD]Total Sum[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0,53[/TD]
[TD="align: right"]18,01[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0,62[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]0,76[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]0,93[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]1,28[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]1,72[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]2,03[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]6,4[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="class: grid, width: 246"]
<tbody>[TR]
[TD]stamps[/TD]
[TD]Total Sum[/TD]
[TD]+6,4+6,4+2,03+1,28+0,76+0,62+0,53[/TD]
[/TR]
[TR]
[TD]0,53[/TD]
[TD="align: right"]18,02[/TD]
[TD]+6,4+6,4+1,72+1,72+0,62+0,62+0,53[/TD]
[/TR]
[TR]
[TD]0,62[/TD]
[TD][/TD]
[TD]+6,4+6,4+1,72+1,28+0,93+0,76+0,53[/TD]
[/TR]
[TR]
[TD]0,76[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0,93[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1,28[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1,72[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2,03[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6,4[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
hippiehacker said:
setup your spreadsheet as follow

[TABLE="class: grid, width: 182, align: center"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]stamps[/TD]
[TD]Total Sum[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]0,53[/TD]
[TD="align: right"]18,01[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]0,62[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]0,76[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]0,93[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]1,28[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]1,72[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]2,03[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]6,4[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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

[TABLE="class: grid, width: 246"]
<tbody>[TR]
[TD]stamps[/TD]
[TD]Total Sum[/TD]
[TD]+6,4+6,4+2,03+1,28+0,76+0,62+0,53[/TD]
[/TR]
[TR]
[TD]0,53[/TD]
[TD="align: right"]18,02[/TD]
[TD]+6,4+6,4+1,72+1,72+0,62+0,62+0,53[/TD]
[/TR]
[TR]
[TD]0,62[/TD]
[TD][/TD]
[TD]+6,4+6,4+1,72+1,28+0,93+0,76+0,53[/TD]
[/TR]
[TR]
[TD]0,76[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]0,93[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1,28[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1,72[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2,03[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6,4[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...

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:
Upvote 0
Followed an Idiot's Guide, but I do get an error when running the macro:

"Compile error: Sub or Function not defined"
 
Upvote 0
m5rcc said:
In Excel 2013, alt+f11 top open VB. Then tools>references and added the references required...
Click to expand...

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
 
Upvote 0
i see can you replace the

Code: 
call findsum

with

Code: 
Call find_combinations

I have modified a script which we use internally
 
Upvote 0
hippiehacker said:
i see can you replace the

Code: 
call findsum

with

Code: 
Call find_combinations

I have modified a script which we use internally
Click to expand...

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...
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
oh oh, I just found out how my excel calculations are NOT including everything I need to calcualte my selling price.
Replies
1
Views
865
KillerOfGiants
K
D
  • Question Question
I don't even know the term for what I need ????
Replies
4
Views
328
SanjayGMusafir
SanjayGMusafir
D
  • Question Question
How can I determine multi-level value fees from a table of fees for a given value?
2 3
Replies
21
Views
4K
daleholden
D
I
  • Question Question
Count Help - a column of different dates I need to compact into how many of each date exists
Replies
9
Views
921
Aladin Akyurek
Aladin Akyurek
VBA learner ITG
  • Question Question
Advice how i would tackle this using an excel formula or vba solution
Replies
1
Views
575
ImranMalek
I

Forum statistics

Threads
1,223,711
Messages
6,174,020
Members
452,542
Latest member
Bricklin

Share this page

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