Auto Round Pack Sizes

Paddy1979

Well-known Member
Joined
Sep 23, 2005
Messages
608
Hello All,

Please can you help?

I have an order form the Worksheet is named 'Stock Orders' Column A contains part codes Column B is for qty's required.

On another worksheet named 'Pack Sizes' column A has part codes and Coulmn B contains pack sizes, i.e. part AI56 comes in packs of 10.

Is there away in VBA where if someone places an order for AI56 qty 6 the cell automatically will round to 10.

If anybody has a link, or any advice that would be much appreciated.
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

Paddy1979

Well-known Member
Joined
Sep 23, 2005
Messages
608
hello wavemehello, i had thought about that but it would mean reformating the order page which we do not want to do
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hi,

but CEILING is the key to proceed

starting with this idea
  A    B        C  
1 CODE Quantity    
2 A6   11       12 
3 A4   18       21 
4 A2   40       40 
5 A3   4        6  
6 A5   6        10 

Stock Orders

[Table-It] version 06 by Erik Van Geit
Code:
RANGE FORMULA (1st cell)
C2:C6 =CEILING(B2,LOOKUP(A2,'Pack Sizes'!$A$2:$A$6,'Pack Sizes'!$B$2:$B$6))

[Table-It] version 06 by Erik Van Geit

refering to
  A    B    
1 CODE pack 
2 A2   5    
3 A3   3    
4 A4   7    
5 A5   10   
6 A6   12   

Pack Sizes

[Table-It] version 06 by Erik Van Geit

record a macro filling in the correct formula in column C
Code:
    ActiveCell.FormulaR1C1 = _
        "=CEILING(RC[-1],LOOKUP(RC[-2],'Pack Sizes'!R2C1:R6C1,'Pack Sizes'!R2C2:R6C2))"

then edit
Code:
    With Target
    .Formula = "=CEILING(" & .Address & ",LOOKUP(" & .Offset(0, -1).Address & _
        ",'Pack Sizes'!A2:A6,'Pack Sizes'!B2:B6))"
    End With
also added a check in case one of the changed cells is empty
=IF(A2="";""; ...)

now let's insert (and delete at the end) a column to put the formulas and copy the results to the targetcolumn...
full code in worksheetmodule
Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim changeRng As Range

Set changeRng = Intersect(Target, Range("B2:B" & Rows.Count))

If changeRng Is Nothing Then Exit Sub

    If changeRng.Areas.Count > 1 Then
    MsgBox "Please change only 1 area at a time", 48, "ERROR"
    Application.Undo
    Exit Sub
    End If

Application.ScreenUpdating = False
Application.EnableEvents = False

    With changeRng
    Columns(.Column + 1).Insert
    .Offset(0, 1).Formula = _
        "=IF(" & .Cells(1).Address(0, 0) & "="""","""",CEILING(" & .Cells(1).Address(0, 0) & ",LOOKUP(" & .Cells(1).Offset(0, -1).Address(0, 0) & _
        ",'Pack Sizes'!$A$2:$A$6,'Pack Sizes'!$B$2:$B$6)))"
    .Value = .Offset(0, 1).Value
    Columns(.Column + 1).Delete
    End With

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
kind regards,
Erik
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832

ADVERTISEMENT

added some flexibility
name of "pack sizes" can be edited on top
last row in "pack sizes" is dynamic

in the same way you could edit the colum labels ...

Code:
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim changeRng As Range
Dim LR As Long

Const checkSH = "Pack Sizes"
LR = Worksheets(checkSH).Cells(Rows.Count, 1).End(xlUp).Row
Set changeRng = Intersect(Target, Range("B2:B" & Rows.Count))

If changeRng Is Nothing Then Exit Sub

    If changeRng.Areas.Count > 1 Then
    MsgBox "Please change only area at a time", 48, "ERROR"
    Application.Undo
    Exit Sub
    End If



Application.ScreenUpdating = False
Application.EnableEvents = False

    With changeRng
    Columns(.Column + 1).Insert
    .Offset(0, 1).Formula = _
        "=IF(" & .Cells(1).Address(0, 0) & "="""","""",CEILING(" & .Cells(1).Address(0, 0) & ",LOOKUP(" & .Cells(1).Offset(0, -1).Address(0, 0) & _
        ",'" & checkSH & "'!$A$2:$A$" & LR & ",'" & checkSH & "'!$B$2:$B$" & LR & ")))"
    .Value = .Offset(0, 1).Value
    Columns(.Column + 1).Delete
    End With

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
 

Forum statistics

Threads
1,136,508
Messages
5,676,270
Members
419,617
Latest member
Shane50GT

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