Making packing list in VBA

[mehidy1437]

Hi There,

I have data in Sheet1 as below.

If the cell value is greater than 40, then I want to divide the cell by 40, put balance value beneath(if there is any balance), also I want to put the number of division done in column T.
How can I do this in Excel VBA?

My desire output in Sheet2 as below.

Sheet1

2233.xlsm
	H	I	J	K	L	M	N
3	STYLE	COLOR	ORD NO	S	M	L	XL
4	MHT01	WHITE	111	100	300	100	100
5	MHT01	RED	111	100	5	130	5
6	MHT01	BLUE	112	120	1	1	1
7	MHT01	BLACK	112	1	1	1	130
Sheet1

Sheet2

2233.xlsm
	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
3	STYLE	COLOR	ORD NO	S	M	L	XL								QTY/CTN	CTN	TTL
4	MHT01	WHITE	111	40											40	2	80
5	MHT01	WHITE	111	20											20	1	20
6	MHT01	WHITE	111		40										40	7	280
7	MHT01	WHITE	111		20										20	1	20
8	MHT01	WHITE	111			40									40	2	80
9	MHT01	WHITE	111			20									20	1	20
10	MHT01	WHITE	111				40								40	2	80
11	MHT01	WHITE	111				20								20	1	20
12	MHT01	RED	111	40											40	2	80
13	MHT01	RED	111	20											20	1	20
14	MHT01	RED	111			40									40	3	120
15	MHT01	RED	111			10									10	1	10
16	MHT01	RED	111		5		5								10	1	10
17	MHT01	BLUE	112	40											40	3	120
18	MHT01	BLUE	112		1	1	1								3	1	3
19	MHT01	BLACK	112				40								40	3	120
20	MHT01	BLACK	112				10								10	1	10
21	MHT01	BLACK	112	1	1	1									3	1	3
Sheet2

Cell Formulas
Range	Formula
S4:S21	S4	=SUM(H4:K4)
U4:U21	U4	=SUM(H4:K4)*T4

 

[mehidy1437]

So far, I have done this much.

Option Explicit

Sub CreatPackingList()
    Dim Rng As Range
    Dim WorkRng As Range
    Dim xNum As Integer
    Dim nThNumber As Double
    Dim nThNumberNoDecimil As Single
    Dim nThNumberNoDecInt As Integer
    Dim coPyRowNThTime As Integer
    Dim xTitleId As String
    Dim totalValue As Integer
    Dim balanceValue As Integer
    Dim cUrrentCellCol As Integer
    Dim cUrrentCellRow As Integer
    Dim leftColNumber As Integer
    Dim rightColNumber As Integer

On Error Resume Next
xTitleId = "Input box--"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xNum = Application.InputBox("Division num", xTitleId, Type:=1)

For Each Rng In WorkRng
If Rng.Value > xNum Then
    nThNumber = Rng.Value / xNum
    nThNumberNoDecimil = nThNumber
    'to remove decimil data
    nThNumberNoDecInt = CInt(Fix(nThNumberNoDecimil))
    totalValue = nThNumberNoDecInt * xNum
    balanceValue = Rng.Value - totalValue
    Rng.Value = xNum
    Rng.EntireRow.Copy
    cUrrentCellCol = Range(Rng.Offset(0, 0), Rng.Offset(0, 0)).Column
    cUrrentCellRow = Range(Rng.Offset(0, 0), Rng.Offset(0, 0)).Row


    'coPyRowNThTime
    '----------------------
        If balanceValue > 0 Then
           coPyRowNThTime = 2
                Range(Rng.Offset(1, 0), Rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                Range(Rng.Offset(1, 0), Rng.Offset(1, 0)).Value = balanceValue
                Range(Rng.Offset(2, 0), Rng.Offset(2, 0)).ClearContents
                'Ctn no at column T
                Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                Cells(cUrrentCellRow, 20).Offset(1, 0).Value = 1

                        If cUrrentCellCol = 8 Then
                        
                        Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                        Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                          ElseIf cUrrentCellCol = 19 Then
                        Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                        Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                            
                        Else
                            leftColNumber = cUrrentCellCol - 1
                            rightColNumber = cUrrentCellCol + 1
                            
                        Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                        Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                        Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
                        Range(Cells(cUrrentCellRow, rightColNumber).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                                  
                        End If
                        'delete emptye row in H-S column, if qty is nothing
                         If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 19).Offset(2, 0))) = 0 Then
                         Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 18).Offset(2, 0)).EntireRow.Delete
                         End If

        Else
           coPyRowNThTime = 1
                    Range(Rng.Offset(1, 0), Rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                    Range(Rng.Offset(1, 0), Rng.Offset(1, 0)).ClearContents
                    
                    'Ctn no at column T
                    Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                            If cUrrentCellCol = 8 Then
                            Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                            
                            ElseIf cUrrentCellCol = 19 Then
                            Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                                
                            Else
                            leftColNumber = cUrrentCellCol - 1
                            rightColNumber = cUrrentCellCol + 1
                            Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                            Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
    
                           End If
                        'delete emptye row in H-S column, if qty is nothing
                         If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0))) = 0 Then
                         Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).EntireRow.Delete
                         End If
            
        End If
    '---------------------
    
 End If
Next

End Sub

 

[mehidy1437]

Hi Guys,

I'm having two issues with the above code.
01. If the range is containing only one row, like H12-K12 then it's only run for first cell I12 & then stop. But it should run till K15.
02. If the range is containing multiple rows as H12-K15, then it's run till I15 & after that, it stops. But it should run till K15.

What am I doing wrong?

Data.....

2233.xlsm
	E	F	G	H	I	J	K
11	STYLE	COLOR	ORD NO	S	M	L	XL
12	MHT01	WHITE	111		300	100	100
13	MHT01	RED	111		5	130
14	MHT01	BLUE	112	120			1
15	MHT01	BLACK	112		120	1	130
Sheet1

Output for RANGE H12 - S12

2233.xlsm
	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
11	STYLE	COLOR	ORD NO	S	M	L	XL									CTN
12	MHT01	WHITE	111		50											6
13	MHT01	WHITE	111			100	100
14	MHT01	RED	111		5	130
15	MHT01	BLUE	112	120			1
16	MHT01	BLACK	112		120	1	130
Sheet1

Output for RANGE H12 - S15

2233.xlsm
	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
11	STYLE	COLOR	ORD NO	S	M	L	XL									CTN
12	MHT01	WHITE	111		50											6
13	MHT01	WHITE	111			50										2
14	MHT01	WHITE	111				50									2
15	MHT01	RED	111			50										2
16	MHT01	RED	111			30										1
17	MHT01	RED	111		5
18	MHT01	BLUE	112	50												2
19	MHT01	BLUE	112	20												1
20	MHT01	BLUE	112				1
21	MHT01	BLACK	112		50											2
22	MHT01	BLACK	112		20											1
23	MHT01	BLACK	112			1	130
Sheet1