Final code required expert opinion

[mehidy1437]

Hello dear experts,

I am writing to you today to ask for your help in reviewing my code. I have been working on this code for a while now, and I am finally ready.

However, I would like to get your feedback on it.
I am especially interested in your feedback on the following:

The overall structure of the code
The readability of the code
The efficiency of the code

Any feedback you can provide would be greatly appreciated.
Thank you for your time and consideration.

Original data:

array v02.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
8	Style	Order	REF	Carton No.			Col	SIZE												Ctns qty	Per Ctn	Tot Qty
9								6	8	10	12	14	XXS	XS	S	M	L	XL	XXL
10	XXX	59	a	1	-	1	X100-								3	3	3	3		1	12	12
11	XXX	59	a	2	-	2	W100-								2	2	2			1	6	6
12	XXX	90	b				F100-							80	160	175	125	60		1	600	600
13	XXX	90	b				X100-							70	157	172	127	67		1	593	593
14	XXX	90	b				W100-							80	158	173	123	60		1	594	594
15	ZZZ	90	b				F100-							80	165	170	125	60		1	600	600
16	ZZZ	90	c				X100-							85	165	180	140	80		1	650	650
17	ZZZ	90	c				W100-							80	160	170	130	60		1	600	600
18	XXX	86	b				F100-							80	160	175	125	60		1	600	600
19	XXX	86	b				X100-							70	157	172	127	67		1	593	593
20	XXX	86	b				W100-							80	158	173	123	60		1	594	594
21	ZZZ	86	b				F100-							80	165	170	125	60		1	600	600
22	ZZZ	86	c				X100-							85	165	180	140	80		1	650	650
23	ZZZ	86	c				W100-							80	160	170	130	60		1	600	600
24	Total=																			14		7292
Sheet18

Cell Formulas
Range	Formula
D11	D11	=F10+1
F10:F11	F10	=D10+T10-1
U10:U23	U10	=SUM($H10:$S10)
T24,V24	T24	=SUM(T10:T23)
V10:V23	V10	=$U10*$T10

Output:

array v02.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
8	Style	Order	REF	Carton No.			Col	SIZE												Ctns qty	Per Ctn	Tot Qty
9								6	8	10	12	14	XXS	XS	S	M	L	XL	XXL
10	XXX	59	a	D1	-	D1	X100-								3	3	3	3		1	12	12
11	XXX	59	a	D2	-	D2	W100-								2	2	2			1	6	6
12	XXX	90	b	D3	-	D4	F100-							35						2	35	70
13	XXX	90	b	D5	-	D8	F100-								35					4	35	140
101	ZZZ	86	c	D199	-	D200	W100-							35						2	35	70
102	ZZZ	86	c	D201	-	D204	W100-								35					4	35	140
103	ZZZ	86	c	D205	-	D208	W100-									35				4	35	140
104	ZZZ	86	c	D209	-	D211	W100-										35			3	35	105
105	ZZZ	86	c	D212	-	D212	W100-											35		1	35	35
106	ZZZ	86	c	D213	-	D213	W100-							10	20	5				1	35	35
107	ZZZ	86	c	D214	-	D214	W100-									25	10			1	35	35
108	ZZZ	86	c	D215	-	D215	W100-										15	20		1	35	35
109	ZZZ	86	c	D216	-	D216	W100-											5		1	5	5
110	Total=																			216		7292
Sheet18

Cell Formulas
Range	Formula
D11:D13,D101:D109	D11	=F10+1
F10	F10	=T10
F11:F13,F101:F109	F11	=F10+T11
U10:U13,U101:U109	U10	=SUM($H10:$S10)
T110,V110	T110	=SUM(T10:T109)
V10:V13,V101:V109	V10	=$U10*$T10

Sub CreatePackingListFinal()
On Error GoTo ErrorHandler ' Error handling starts here

  Dim answer As Integer
  answer = MsgBox("This will create the packing list" & vbNewLine & _
    " " & vbNewLine & "A8 value should be Style" & vbNewLine & _
    "B8-C8-G8 should be Order-Ref-Color" & vbNewLine & "D8-E8-F8 should be carton srl no" & vbNewLine & _
    "H9:S9 should be size 4-6-S-M-L or any" & vbNewLine & "T8 should be Ctns Qty" & vbNewLine & " " & vbNewLine & _
    "Data should began from A10 to below" & vbNewLine & "Don't keep any blank row, in the range A10-S~" & vbNewLine & _
    "**A last row value should be Total=" & vbNewLine & "**Unique combination formed with Style-Order-Color/ A-B-G column", _
    vbInformation + vbYesNo, "PKL Information and Confirmation")
  If answer = vbNo Then Exit Sub
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableAnimations = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim ws As Worksheet
    ''Set the active sheet
    Set ws = ActiveSheet

    Dim valuesArray As Variant
    Dim resultArray As Variant
    Dim outputArray As Variant
    Dim rowIndex As Long, columnIndex As Long, lastNonEmptyColumn As Long
    Dim rowCounter As Long, nextRowToInsert As Long, rowCounter2 As Long
    Dim combinedRange As Range
    Dim rowsToDelete As Range ' Declare rowsToDelete as Range
    Dim isEmptyRow As Boolean
    Dim moveTobelow As Long
    Dim k As Long, i As Long, j As Long

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim qtCols As Long, qtColf As Long, ttlCol As Long, ctnQty As Long
    Dim styleCol As Long, ordCol As Long, refCol As Long, colCol As Long, dataRow As Long
    qtCols = 8
    qtColf = 19
    ttlCol = qtColf - qtCols + 1
    'ctnQty = 40  'getting form inputbox below
    styleCol = 1
    ordCol = 2
    refCol = 3
    colCol = 7
    dataRow = 10
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ctnQty:
 ctnQty = Application.InputBox("PCs per carton", "Division number", Type:=1)
    If ctnQty = False Then
        Exit Sub   'User canceled
    ElseIf ctnQty / ctnQty <> 1 Then
        GoTo ctnQty
    ElseIf Trim(ctnQty) = "" Then
        'MsgBox "Input is empty"
        GoTo ctnQty
    End If
''''''''''''''''''''''''''''''''''''''create Dynamic Range--1111''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim lastRowStar As Long, lastColumnStar As Long, stRng As Range
    Dim firstRow As Long, lastRowZ As Long, WorkRng As Range
    
    Dim sStyle As String, sTotal As String
    ''Set the search values
    sStyle = "Style"
    sTotal = "Total="
    
    lastRowStar = ws.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lastColumnStar = ws.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    ' Set the range for searching
    Set stRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRowStar, lastColumnStar))
    
    firstRow = stRng.Find(What:=sStyle, After:=ws.Cells(lastRowStar, lastColumnStar), LookIn:=xlFormulas, LookAt:=xlWhole, _
        MatchCase:=False, SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 2
    lastRowZ = stRng.Find(What:=sTotal, After:=ws.Cells(lastRowStar, lastColumnStar), LookIn:=xlFormulas, LookAt:=xlWhole, _
        MatchCase:=False, SearchDirection:=xlNext, SearchOrder:=xlByRows).Row - 1
        
    Set WorkRng = ws.Range(Cells(firstRow, qtCols), Cells(lastRowZ, qtColf))
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' Load range into a variant array
valuesArray = ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).Value

''''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''
Dim cleanedValue As String
For i = 1 To UBound(valuesArray, 1)
    For j = 1 To UBound(valuesArray, 2)
        ' Check if the cell is not empty
        If Not IsEmpty(valuesArray(i, j)) Then
            ' Convert the value to string
            cleanedValue = CStr(valuesArray(i, j))
            
            ' Trim the value to remove leading and trailing spaces
            cleanedValue = Trim(cleanedValue)
            
            ' Clean the value to remove non-printable characters
            Dim printableChars As String
            printableChars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~ "
            Dim cleanedResult As String
            cleanedResult = ""
            
            'Dim k As Long
            Dim char As String
            For k = 1 To Len(cleanedValue)
                char = Mid(cleanedValue, k, 1)
                If InStr(printableChars, char) > 0 Then
                    cleanedResult = cleanedResult & char
                End If
            Next k
            
            ' Assign the cleaned value back to the array
            valuesArray(i, j) = cleanedResult
        End If
    Next j
Next i
    ' Stop
    ' clear contents
    ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).ClearContents
    ' write array back to workhseet
    ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)) = valuesArray
''''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''

    ' Load range into a variant array
    valuesArray = ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).Value
    
    ' Count the number of rows needed for the output
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
        'For columnIndex = LBound(valuesArray, 2) To UBound(valuesArray, 2)
        For columnIndex = qtCols To qtColf 'quantity cell
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then
                lastNonEmptyColumn = columnIndex
            End If
        Next columnIndex

        For columnIndex = qtCols To qtColf
            Dim currentValue As Double
            currentValue = valuesArray(rowIndex, columnIndex)

            If currentValue > 0 And currentValue < ctnQty Then
                rowCounter = rowCounter + 1
            ' Check if division result is an integer or a fraction
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
                ' Integer division or value less than 30, count as 1
                If columnIndex = lastNonEmptyColumn Then
                    rowCounter = rowCounter + 2
                Else
                    rowCounter = rowCounter + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
                ' Fraction division, count as 2
                rowCounter = rowCounter + 2
            Else
                'Do nothing
            End If
        Next columnIndex
    Next rowIndex

    ' Resize the result and output arrays
    ReDim resultArray(1 To rowCounter, 1 To 1)
    ReDim outputArray(1 To rowCounter, 1 To UBound(valuesArray, 2) + 1) ' Increase column size by 1

    ' Perform the division operation and store the results in the result and output arrays
    rowCounter = 1
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
        For columnIndex = qtCols To qtColf
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then
                lastNonEmptyColumn = columnIndex
            End If
        Next columnIndex

        For columnIndex = qtCols To qtColf
            currentValue = valuesArray(rowIndex, columnIndex)
            Dim intNumb As Long
            intNumb = Int(currentValue / ctnQty)

            ' Check if division result is an integer or a fraction
            If currentValue > 0 And currentValue < ctnQty Then
                ' Integer division or value less than 30, count as 1
                resultArray(rowCounter, styleCol) = currentValue
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter, columnIndex) = currentValue
                outputArray(rowCounter, UBound(outputArray, 2)) = 1 ' Store 1 in the additional column
                rowCounter = rowCounter + 1
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
                ' Integer division, count as 1
                If columnIndex = lastNonEmptyColumn Then
                    resultArray(rowCounter, styleCol) = ctnQty
                    outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                    outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                    outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                    outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                    outputArray(rowCounter, columnIndex) = ctnQty
                    outputArray(rowCounter, UBound(outputArray, 2)) = intNumb ' Store intNumb in the additional column
                    rowCounter = rowCounter + 1

                    resultArray(rowCounter, styleCol) = ""
                    outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                    outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                    outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                    outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                    outputArray(rowCounter, columnIndex) = ""
                    outputArray(rowCounter, UBound(outputArray, 2)) = 1 ' Store intNumb in the additional column
                    rowCounter = rowCounter + 1
                Else
                    resultArray(rowCounter, styleCol) = ctnQty
                    outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                    outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                    outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                    outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                    outputArray(rowCounter, columnIndex) = ctnQty
                    outputArray(rowCounter, UBound(outputArray, 2)) = intNumb ' Store intNumb in the additional column
                    rowCounter = rowCounter + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
                ' Fraction division, count as 2
                resultArray(rowCounter, styleCol) = ctnQty
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter, columnIndex) = ctnQty
                outputArray(rowCounter, UBound(outputArray, 2)) = intNumb ' Store intNumb in the additional column
                rowCounter = rowCounter + 1

                resultArray(rowCounter, styleCol) = currentValue - (intNumb * ctnQty)
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter, columnIndex) = currentValue - (intNumb * ctnQty)
                outputArray(rowCounter, UBound(outputArray, 2)) = 1 ' Store 1 in the additional column
                rowCounter = rowCounter + 1
            Else
                'Do nothing
            End If
        Next columnIndex
    Next rowIndex

    Dim lastRow As Long
    
    ' Iterate through the array and update values below 30
    For i = LBound(outputArray, 1) To UBound(outputArray, 1)
        For j = qtCols To qtColf
            If IsNumeric(outputArray(i, j)) And outputArray(i, j) < ctnQty Then
                ' Find the last row for the corresponding style, order and color
                lastRow = -1
                For k = UBound(outputArray, 1) To i + 1 Step -1
                    'grabing the last row for each style-order-color, logical argument
                       If outputArray(k, styleCol) = outputArray(i, styleCol) And _
                        outputArray(k, ordCol) = outputArray(i, ordCol) And _
                        outputArray(k, colCol) = outputArray(i, colCol) Then
                        lastRow = k
                        Exit For
                    End If
                Next k

                'Update the value to the last row of the corresponding order and color
                If lastRow <> -1 Then
                    If Not IsEmpty(outputArray(lastRow, j)) Then
                        outputArray(lastRow, j) = outputArray(lastRow, j)
                    Else
                        outputArray(lastRow, j) = outputArray(i, j)
                    End If
                    outputArray(i, j) = ""
                End If
            End If
        Next j
    Next i
'Stop
    nextRowToInsert = dataRow
    ' Insert the output array back into the sheet
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
        For columnIndex = qtCols To qtColf
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then
                lastNonEmptyColumn = columnIndex
            End If
        Next columnIndex

        rowCounter2 = 0
        For columnIndex = qtCols To qtColf
            currentValue = valuesArray(rowIndex, columnIndex)
            If currentValue > 0 And currentValue < ctnQty Then
                 rowCounter2 = rowCounter2 + 1
            ' Check if division result is an integer or a fraction
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
                ' Integer division, count as 1
                If columnIndex = lastNonEmptyColumn Then
                    rowCounter2 = rowCounter2 + 2
                Else
                    rowCounter2 = rowCounter2 + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
                ' Fraction division, count as 2
                rowCounter2 = rowCounter2 + 2
            Else
              'do nothing
            End If
        Next columnIndex
        
        ws.Rows(nextRowToInsert).EntireRow.Copy
        ws.Rows(nextRowToInsert).Resize(rowCounter2 - 1).Insert Shift:=xlDown
        ws.Range(Cells(nextRowToInsert + 1, "H"), Cells(nextRowToInsert + rowCounter2 - 1, "S")).ClearContents
        nextRowToInsert = nextRowToInsert + rowCounter2
    Next rowIndex
' Insert the output array back into the sheet
ws.Range("A10").Resize(rowCounter - 1, UBound(valuesArray, 2) + 1).Value = outputArray
    

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Stop
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim styleColumn As Variant
styleColumn = Application.Index(outputArray, 0, styleCol)  ''Assign column 1 of outputArray to styleColumn variant

Dim orderColumn As Variant
orderColumn = Application.Index(outputArray, 0, ordCol)  ''Assign column 2 of outputArray to orderColumn variant

Dim colorColumn As Variant
colorColumn = Application.Index(outputArray, 0, colCol) ''Assign column 3 of outputArray to colorColumn variant

Dim style As String
Dim order As String
Dim color As String
Dim totalValue As Double
Dim roundedResult As Long
'Dim combinedRange As Range

' Iterate through the range from bottom to top to find unique combinations and calculate totals
For i = UBound(outputArray, 1) To 2 Step -1
    style = orderColumn(i, 1)
    order = orderColumn(i, 1)
    color = colorColumn(i, 1)

    If style <> "" And order <> "" And color <> "" Then
        Dim isUnique As Boolean
        isUnique = True

        ' Check if the combination is already printed in a previous iteration
        For j = i + 1 To UBound(outputArray, 1)
            'grabing the unique row for each style-order-color, logical argument
            If styleColumn(j, 1) = style And orderColumn(j, 1) = order And colorColumn(j, 1) = color Then
                isUnique = False
                Exit For
            End If
        Next j

        If isUnique Then
            lastRow = i ' current row is the last row for this combination

            ' Calculate the total value for columns D, E, and F in the last row
            totalValue = 0
            For Each columnNum In Array(8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19)
                If IsNumeric(outputArray(lastRow, columnNum)) Then
                    totalValue = totalValue + outputArray(lastRow, columnNum)
                End If
            Next columnNum
                        
            ' Divide the totalValue by 30 and round up the result
            roundedResult = Application.WorksheetFunction.Ceiling(totalValue / ctnQty, 1) - 1
            
            If roundedResult > 0 Then
                ' Calculate the remaining balance to distribute

                ' Copy the last row and shift it below by roundedResult times to the active sheet
                Dim tempRange As Range
                Set tempRange = Rows(lastRow + (dataRow - 1)).Resize(1, UBound(outputArray, 2))

                ' Initialize the combinedRange with the last copied row
                Set combinedRange = tempRange
                ' Initialize a counter for inserted rows
                Dim insertedRowCount As Long
                'insertedRowCount = 0
                
                For k = 1 To roundedResult
                    ' Insert a new row below the lastRow
                    Rows(lastRow + k + (dataRow - 1)).Insert Shift:=xlShiftDown
                    
                    ' Copy the contents of the tempRange and paste it into the newly inserted row
                    tempRange.EntireRow.Copy Destination:=Rows(lastRow + k + (dataRow - 1))
                    ' Remove cell values in columns 4 to 6
                    With Rows(lastRow + k + (dataRow - 1))
                           .Range(Cells(1, qtCols), Cells(1, qtColf)).ClearContents
                    End With
                    
                    ' Update the combinedRange to include the newly inserted row
                    Set combinedRange = Union(combinedRange, Rows(lastRow + k + (dataRow - 1)).Resize(1, UBound(outputArray, 2)))
                    ' Increment the inserted row count
                    insertedRowCount = insertedRowCount + 1
                Next k
   
               'Stop
                Dim targetValue As Long
                Dim rowRange As Range
                Dim cell As Range
                Dim sum As Long
               ' Dim remainingBalance As Long
                
                ' Set the target value
                targetValue = ctnQty
                ' Loop through each row in the combined range
                For Each rowRange In combinedRange.Rows
                sum = 0
                For Each cell In rowRange.Cells
                    If cell.Column >= qtCols And cell.Column <= qtColf Then
                        sum = sum + cell.Value
                    End If
                Next cell
                'Stop
                If sum > ctnQty Then
                    remainingBalance = targetValue
                    ' Loop through each cell in the row range
                    For Each cell In rowRange.Cells
                        ' Skip cells outside columns D:F
                        If cell.Column >= qtCols And cell.Column <= qtColf Then
                            'Debug.Print cell.Column
                            If cell.Value <> "" Then
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                                If remainingBalance <= 0 Then
                                    cell.Offset(1, 0).Value = cell.Value
                                    cell.Value = ""
                                    remainingBalance = 0
                                ElseIf remainingBalance >= cell.Value Then
                                   cell.Value = cell.Value
                                   remainingBalance = remainingBalance - cell.Value
                                 ElseIf remainingBalance < cell.Value Then
                                    moveTobelow = cell.Value - remainingBalance
                                    cell.Offset(1, 0).Value = moveTobelow
                                    cell.Value = remainingBalance
                                    remainingBalance = cell.Value - remainingBalance
                                 End If
                                 'remainingBalance = remainingBalance - cell.Value
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                            End If
                        End If
                    Next cell
                End If
                Next rowRange
                        End If
                    End If
                End If
            Next i

Dim lastRowOutputArray As Long, finalLastRow As Long
lastRowOutputArray = UBound(outputArray, 1)
finalLastRow = lastRowOutputArray + insertedRowCount + firstRow - 1 '1 or firstRow: coz range start from row 10

' Check and delete rows if columns 4 to 6 are empty
Dim rowToDelete As Long
For rowToDelete = finalLastRow To firstRow Step -1
    If WorksheetFunction.CountBlank(Range("H" & rowToDelete & ":S" & rowToDelete)) = ttlCol Then
        Rows(rowToDelete).EntireRow.Delete
        finalLastRow = finalLastRow - 1 ' Adjust the finalLastRow after deleting a row
    End If
Next rowToDelete

'custome formating column D & F as D1,D2,D3
    ws.Cells(firstRow, 4).NumberFormat = """D""General"
    ws.Cells(firstRow, 6).NumberFormat = """D""General"
    ws.Cells(firstRow, 4).Offset(1, 0).NumberFormat = """D""General"
    ws.Cells(firstRow, 6).Offset(1, 0).NumberFormat = """D""General"
    'Stop
'carton Number
    ws.Range("D10").Value = 1
    ws.Range("E10").Value = "-"
    ws.Range("F10").Formula = "=T10"
    ws.Range("D11").Formula = "=F10+1"
    ws.Range("E11").Value = "-"
    ws.Range("F11").Formula = "=F10+T11"
    'ws.Range("D11:F11").Copy Range("D12:F" & lastRowZ)
    ws.Range("D11:F" & finalLastRow).FillDown

'Total value to last row
    ws.Range("T" & finalLastRow + 1).Formula = "=SUM(T10:T" & finalLastRow & ")"
    ws.Range("V" & finalLastRow + 1).Formula = "=SUM(V10:V" & finalLastRow & ")"
    ws.Range("X" & finalLastRow + 1).Formula = "=ROUND(SUM(X10:X" & finalLastRow & "),2)"
    ws.Range("Y" & finalLastRow + 1).Formula = "=ROUND(SUM(Y10:Y" & finalLastRow & "),2)"
    ws.Range("Z" & finalLastRow + 1).Formula = "=ROUND(SUM(Z10:Z" & finalLastRow & "),2)"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

Exit Sub ' Skip error handler if no error occurs
ErrorHandler:
    MsgBox "An error occurred: " & Err.Description ' Display error message
Exit Sub
End Sub

 

[Micron]

I'm not going to comment regarding efficiency or whatever for what the code does, as I'm more of an Access coder than Excel, but I will pass on what I see/think in general terms.

You declared ctnQty as a long, yet are asking if it equals a boolean. It will work since False is equivalent to 0, which can be a long (or other types such as integer, double, single) but I would not mix my logical tests and variable types. It's bad practice IMO.

IF user enters 0, you will get a division by zero error.
Some would say that the use of GoTo to control flow beyond that of error handling is poor practice. I tend to think that way.

I wouldn't expect leading spaces before numbers would be passed via input box to a long variable. If not, there is no need to Trim. For all of that If block, I think I'd test that
- input is numeric ("", null or spaces are not, so no need to individually test)
- is not zero (or is at least >0 if negative values are not a concern) to avoid div by zero
and forget the GoTo's. I have yet to see a case where GoTo's are truly needed beyond error handling.

I almost always preface every custom object or variable with a type prefix so I never have to look back to the top to see what it is. ctnQty would be lngCtnQty or just lngQty. An exeption would be Lrow As Long (for working with last row) since I know that row number values are Long (at least I believe so). Alternatively, I might use lngRow but that might suggest row, not last row).

If you raise an unhandled error, all the app settings that you altered/disabled will remain that way! Better:

exitHere:
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With
Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description ' Display error message
    Resume exitHere

 

[kevin9999]

Instead of

Dim ws as Worksheet
Set ws = ActiveSheet

which will cause problems if the code is run when a different sheet is active, be very specific when setting object variables, such as :

Dim ws as Worksheet
Set ws = Worksheets("Sheet1")   'or whatever the actual sheet is called.

 

[mehidy1437]

Thank you both for taking your time to review the code.
I will check & keep in my mind to proceed further.

 

[johnnyL]

Here is some constructive criticism from my brief look at the code:

1) Keep your 'Dim' lines outside of (above) loop routines, no sense in constantly Dimming, I am surprised Excel doesn't complain about 'Duplicate Declaration' when they are inside of a loop, but oh well.
2) When you have variables that will not change values, you should consider making them 'Const' variables. Theoretically, they process faster that way.
3) Using RegExp is usually faster than looping through each character in each cell for the 'printableChars'
4) When commenting what a single line of code does, place the comment at the end of the line of the code, not on top of it.
5) You have the line of code:

       style = orderColumn(i, 1)

Shouldn't it be:

        style = styleColumn(i, 1)

?
6) Don't put an 'On Error GoTo' statement at the very top of your code, that screams "I don't know what I am doing, so if I messed something up & didn't anticipate messing something up, just do something else. The 'On Error GoTo' statement should be used judiciously (briefly) to occasionally handle errors that can handle any errors that you expect might occur, if you use it in any other capacity, you are just hiding code errors that you should resolve.


All that being said, The following is some code that I have come up with reflecting most of those changes. I have also included the suggestion of @Micron concerning the suggestion of re-enabling settings if your 'On Error GoTo ErrorHandler' is triggered. I also included some shortening of the code. I made a bunch of changes, & I can't remember them all, but it seems to still return the same results as the original code you provided.

Option Explicit


Sub CreatePackingListFinal()
'
    On Error GoTo ErrorHandler ' Error handling starts here
'
    Dim answer As Long
'
    answer = MsgBox("This will create the packing list" & vbNewLine & _
            " " & vbNewLine & "A8 value should be Style" & vbNewLine & _
            "B8-C8-G8 should be Order-Ref-Color" & vbNewLine & "D8-E8-F8 should be carton srl no" & vbNewLine & _
            "H9:S9 should be size 4-6-S-M-L or any" & vbNewLine & "T8 should be Ctns Qty" & vbNewLine & " " & vbNewLine & _
            "Data should began from A10 to below" & vbNewLine & "Don't keep any blank row, in the range A10-S~" & vbNewLine & _
            "**A last row value should be Total=" & vbNewLine & "**Unique combination formed with Style-Order-Color/ A-B-G column", _
            vbInformation + vbYesNo, "PKL Information and Confirmation")
'
    If answer = vbNo Then Exit Sub
'
    With Application
          .ScreenUpdating = False
            .EnableEvents = False
        .EnableAnimations = False
             .Calculation = xlCalculationManual
           .DisplayAlerts = False
    End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
    Dim ws As Worksheet
'' Set the active sheet
    Set ws = ActiveSheet
'
    Dim i                   As Long, j                  As Long, k                      As Long
    Dim rowIndex            As Long, columnIndex        As Long, lastNonEmptyColumn     As Long
    Dim rowCounter          As Long, nextRowToInsert    As Long, rowCounter2            As Long
    Dim ttlCol              As Long, ctnQty             As Long, remainingBalance       As Long
    Dim combinedRange       As Range
    Dim columnNum           As Variant
    Dim outputArray         As Variant, resultArray     As Variant, valuesArray         As Variant
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const styleCol As Long = 1: Const ordCol As Long = 2: Const refCol As Long = 3
    Const colCol As Long = 7: Const qtCols As Long = 8: Const qtColf As Long = 19
    Const dataRow As Long = 10
    Const printableChars As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~ "
'
    ttlCol = qtColf - qtCols + 1
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ctnQty:
'
    ctnQty = Application.InputBox("PCs per carton", "Division number", Type:=1)
'
    If ctnQty = False Then
        Exit Sub   'User canceled
    ElseIf Trim(ctnQty) = "" Then
        'MsgBox "Input is empty"
        GoTo ctnQty
    End If
'
''''''''''''''''''''''''''''''''''''''create Dynamic Range--1111''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim lastRowStar     As Long, lastColumnStar     As Long, stRng                  As Range
    Dim firstRow        As Long, lastRowZ           As Long, WorkRng                As Range
    Dim sStyle As String, sTotal As String
'
'' Set the search values
    sStyle = "Style"
    sTotal = "Total="
'
    lastRowStar = ws.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lastColumnStar = ws.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'
'' Set the range for searching
    Set stRng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRowStar, lastColumnStar))
'
    firstRow = stRng.Find(What:=sStyle, After:=ws.Cells(lastRowStar, lastColumnStar), LookIn:=xlFormulas, LookAt:=xlWhole, _
            MatchCase:=False, SearchDirection:=xlNext, SearchOrder:=xlByRows).Row + 2
    lastRowZ = stRng.Find(What:=sTotal, After:=ws.Cells(lastRowStar, lastColumnStar), LookIn:=xlFormulas, LookAt:=xlWhole, _
            MatchCase:=False, SearchDirection:=xlNext, SearchOrder:=xlByRows).Row - 1
'
    Set WorkRng = ws.Range(Cells(firstRow, qtCols), Cells(lastRowZ, qtColf))
'
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'' Load range into a variant array
    valuesArray = ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).Value
''''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''
    Dim RegEx As Object
    Set RegEx = CreateObject("VBScript.RegExp")
'
    RegEx.Global = True
    RegEx.Pattern = "[^\w\s!""#$%&'()*+,-./:;<=>?@[\\\]^_`{|}~]"  ' Non-printable characters regex
'
    For i = 1 To UBound(valuesArray, 1)
        For j = 1 To UBound(valuesArray, 2)
'' Check if the cell is not empty
            If Not IsEmpty(valuesArray(i, j)) Then
'' Convert the value to string & Trim the value to remove leading and trailing spaces
                valuesArray(i, j) = Trim(CStr(valuesArray(i, j)))
'' Clean the value to remove non-printable characters using the regular expression
                valuesArray(i, j) = RegEx.Replace(valuesArray(i, j), "")
            End If
        Next j
    Next i
'' write array back to worksheet
    ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).Value = valuesArray
''''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''
'
'' Load range into a variant array
    valuesArray = ws.Range(Cells(firstRow, 1), Cells(lastRowZ, qtColf)).Value
'
'' Count the number of rows needed for the output
    Dim currentValue As Double
'
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
'
        For columnIndex = qtCols To qtColf 'quantity cell
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then lastNonEmptyColumn = columnIndex
        Next columnIndex
'
        For columnIndex = qtCols To qtColf
            currentValue = valuesArray(rowIndex, columnIndex)
'
            If currentValue > 0 And currentValue < ctnQty Then
                rowCounter = rowCounter + 1
'' Check if division result is an integer or a fraction
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
'' Integer division or value less than 30, count as 1
                If columnIndex = lastNonEmptyColumn Then
                    rowCounter = rowCounter + 2
                Else
                    rowCounter = rowCounter + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
'' Fraction division, count as 2
                rowCounter = rowCounter + 2
            Else
                'Do nothing
            End If
        Next columnIndex
    Next rowIndex
'
'' Resize the result and output arrays
    ReDim resultArray(1 To rowCounter, 1 To 1)
    ReDim outputArray(1 To rowCounter, 1 To UBound(valuesArray, 2) + 1)                 ' Increase column size by 1
'
'' Perform the division operation and store the results in the result and output arrays
    rowCounter = 1
'
    Dim intNumb As Long
'
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
'
        For columnIndex = qtCols To qtColf
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then lastNonEmptyColumn = columnIndex
        Next columnIndex
'
        For columnIndex = qtCols To qtColf
            currentValue = valuesArray(rowIndex, columnIndex)
            intNumb = Int(currentValue / ctnQty)
'
'' Check if division result is an integer or a fraction
            If currentValue > 0 And currentValue < ctnQty Then
'' Integer division or value less than 30, count as 1
                resultArray(rowCounter, styleCol) = currentValue
'
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter, columnIndex) = currentValue
                outputArray(rowCounter, UBound(outputArray, 2)) = 1 ' Store 1 in the additional column
'
                rowCounter = rowCounter + 1
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
'' Integer division, count as 1
                resultArray(rowCounter, styleCol) = ctnQty
'
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter, columnIndex) = ctnQty
                outputArray(rowCounter, UBound(outputArray, 2)) = intNumb ' Store intNumb in the additional column
'
                rowCounter = rowCounter + 1
'
                If columnIndex = lastNonEmptyColumn Then
                    resultArray(rowCounter, styleCol) = ""
'
                    outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                    outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                    outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                    outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                    outputArray(rowCounter, columnIndex) = ""
                    outputArray(rowCounter, UBound(outputArray, 2)) = 1 ' Store 1 in the additional column
'
                    rowCounter = rowCounter + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
'' Fraction division, count as 2
                resultArray(rowCounter, styleCol) = ctnQty
                resultArray(rowCounter + 1, styleCol) = currentValue - (intNumb * ctnQty)
'
                outputArray(rowCounter, styleCol) = valuesArray(rowIndex, styleCol)
                outputArray(rowCounter + 1, styleCol) = valuesArray(rowIndex, styleCol)
'
                outputArray(rowCounter, ordCol) = valuesArray(rowIndex, ordCol)
                outputArray(rowCounter + 1, ordCol) = valuesArray(rowIndex, ordCol)
'
                outputArray(rowCounter, refCol) = valuesArray(rowIndex, refCol)
                outputArray(rowCounter + 1, refCol) = valuesArray(rowIndex, refCol)
'
                outputArray(rowCounter, colCol) = valuesArray(rowIndex, colCol)
                outputArray(rowCounter + 1, colCol) = valuesArray(rowIndex, colCol)
'
                outputArray(rowCounter, columnIndex) = ctnQty
                outputArray(rowCounter + 1, columnIndex) = currentValue - (intNumb * ctnQty)
'
                outputArray(rowCounter, UBound(outputArray, 2)) = intNumb ' Store intNumb in the additional column
                outputArray(rowCounter + 1, UBound(outputArray, 2)) = 1 ' Store 1 in the additional column
'
                rowCounter = rowCounter + 2
            Else
                'Do nothing
            End If
        Next columnIndex
    Next rowIndex
'
    Dim lastRow As Long
'
'' Iterate through the array and update values below 30
    For i = LBound(outputArray, 1) To UBound(outputArray, 1)
        For j = qtCols To qtColf
            If IsNumeric(outputArray(i, j)) And outputArray(i, j) < ctnQty Then
'' Find the last row for the corresponding style, order and color
                lastRow = -1
'
                For k = UBound(outputArray, 1) To i + 1 Step -1
'' grabing the last row for each style-order-color, logical argument
                    If outputArray(k, styleCol) = outputArray(i, styleCol) And _
                            outputArray(k, ordCol) = outputArray(i, ordCol) And _
                            outputArray(k, colCol) = outputArray(i, colCol) Then
                        lastRow = k
                        Exit For
                    End If
                Next k
'
'' Update the value to the last row of the corresponding order and color
                If lastRow <> -1 Then
                    If Not IsEmpty(outputArray(lastRow, j)) Then
                        outputArray(lastRow, j) = outputArray(lastRow, j)
                    Else
                        outputArray(lastRow, j) = outputArray(i, j)
                    End If
'
                    outputArray(i, j) = ""
                End If
            End If
        Next j
    Next i
'
    nextRowToInsert = dataRow
'
'' Insert the output array back into the sheet
    For rowIndex = 1 To UBound(valuesArray, 1)
        lastNonEmptyColumn = 0
'
        For columnIndex = qtCols To qtColf
            If Not IsEmpty(valuesArray(rowIndex, columnIndex)) Then
                lastNonEmptyColumn = columnIndex
            End If
        Next columnIndex
'
        rowCounter2 = 0
'
        For columnIndex = qtCols To qtColf
            currentValue = valuesArray(rowIndex, columnIndex)
'
            If currentValue > 0 And currentValue < ctnQty Then
                 rowCounter2 = rowCounter2 + 1
'' Check if division result is an integer or a fraction
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) = (currentValue / ctnQty) Then
'' Integer division, count as 1
                If columnIndex = lastNonEmptyColumn Then
                    rowCounter2 = rowCounter2 + 2
                Else
                    rowCounter2 = rowCounter2 + 1
                End If
            ElseIf currentValue > (ctnQty - 1) And Int(currentValue / ctnQty) <> (currentValue / ctnQty) Then
'' Fraction division, count as 2
                rowCounter2 = rowCounter2 + 2
            Else
              'do nothing
            End If
        Next columnIndex
'
        ws.Rows(nextRowToInsert).EntireRow.Copy
        ws.Rows(nextRowToInsert).Resize(rowCounter2 - 1).Insert Shift:=xlDown
        ws.Range(Cells(nextRowToInsert + 1, "H"), Cells(nextRowToInsert + rowCounter2 - 1, "S")).ClearContents
'
        nextRowToInsert = nextRowToInsert + rowCounter2
    Next rowIndex
'' Insert the output array back into the sheet
    ws.Range("A10").Resize(rowCounter - 1, UBound(valuesArray, 2) + 1).Value = outputArray
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Stop
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim isUnique            As Boolean
    Dim totalValue          As Double
    Dim insertedRowCount    As Long
    Dim roundedResult       As Long
    Dim sum                 As Long
    Dim targetValue         As Long
    Dim cell                As Range, rowRange          As Range, tempRange         As Range
    Dim color               As String, order            As String, style            As String
    Dim colorColumn         As Variant, orderColumn     As Variant, styleColumn     As Variant
'
    styleColumn = Application.Index(outputArray, 0, styleCol)  ''Assign column 1 of outputArray to styleColumn variant
    orderColumn = Application.Index(outputArray, 0, ordCol)  ''Assign column 2 of outputArray to orderColumn variant
    colorColumn = Application.Index(outputArray, 0, colCol) ''Assign column 3 of outputArray to colorColumn variant
'
'' Iterate through the range from bottom to top to find unique combinations and calculate totals
    For i = UBound(outputArray, 1) To 2 Step -1
        style = orderColumn(i, 1)
        order = orderColumn(i, 1)
        color = colorColumn(i, 1)
'
        If style <> "" And order <> "" And color <> "" Then
            isUnique = True
'
'' Check if the combination is already printed in a previous iteration
            For j = i + 1 To UBound(outputArray, 1)
'' grabing the unique row for each style-order-color, logical argument
                If styleColumn(j, 1) = style And orderColumn(j, 1) = order And colorColumn(j, 1) = color Then
                    isUnique = False
                    Exit For
                End If
            Next j
'
            If isUnique Then
                lastRow = i ' current row is the last row for this combination
'
'' Calculate the total value for columns D, E, and F in the last row
                totalValue = 0
'
                For Each columnNum In Array(8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19)
                    If IsNumeric(outputArray(lastRow, columnNum)) Then totalValue = _
                            totalValue + outputArray(lastRow, columnNum)
                Next columnNum
                        
'' Divide the totalValue by 30 and round up the result
                roundedResult = Application.WorksheetFunction.Ceiling(totalValue / ctnQty, 1) - 1
'
                If roundedResult > 0 Then
'' Calculate the remaining balance to distribute
'
'' Copy the last row and shift it below by roundedResult times to the active sheet
'
                    Set tempRange = Rows(lastRow + (dataRow - 1)).Resize(1, UBound(outputArray, 2))
'' Initialize the combinedRange with the last copied row
                    Set combinedRange = tempRange
'
                    For k = 1 To roundedResult
'' Insert a new row below the lastRow
                        Rows(lastRow + k + (dataRow - 1)).Insert Shift:=xlShiftDown
'
'' Copy the contents of the tempRange and paste it into the newly inserted row
                        tempRange.EntireRow.Copy Destination:=Rows(lastRow + k + (dataRow - 1))
'' Remove cell values in columns 4 to 6
                        With Rows(lastRow + k + (dataRow - 1))
                           .Range(Cells(1, qtCols), Cells(1, qtColf)).ClearContents
                        End With
'
'' Update the combinedRange to include the newly inserted row
                        Set combinedRange = Union(combinedRange, Rows(lastRow + k + (dataRow - 1)).Resize(1, UBound(outputArray, 2)))
'' Increment the inserted row count
                        insertedRowCount = insertedRowCount + 1
                    Next k
'
'' Set the target value
                    targetValue = ctnQty
'' Loop through each row in the combined range
                    For Each rowRange In combinedRange.Rows
                        sum = 0
'
                        For Each cell In rowRange.Cells
                            If cell.Column >= qtCols And cell.Column <= qtColf Then sum = sum + cell.Value
                        Next cell
'
                        If sum > ctnQty Then
                            remainingBalance = targetValue
'' Loop through each cell in the row range
                            For Each cell In rowRange.Cells
'' Skip cells outside columns D:F
                                If cell.Column >= qtCols And cell.Column <= qtColf Then
                                    If cell.Value <> "" Then
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                                        If remainingBalance <= 0 Then
                                            cell.Offset(1, 0).Value = cell.Value
                                            cell.Value = ""
                                            remainingBalance = 0
                                        ElseIf remainingBalance >= cell.Value Then
                                            cell.Value = cell.Value
                                            remainingBalance = remainingBalance - cell.Value
                                        ElseIf remainingBalance < cell.Value Then
                                            cell.Offset(1, 0).Value = cell.Value - remainingBalance
                                            cell.Value = remainingBalance
                                            remainingBalance = cell.Value - remainingBalance
                                        End If
'
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                                    End If
                                End If
                            Next cell
                        End If
                    Next rowRange
                End If
            End If
        End If
    Next i
'
    Dim lastRowOutputArray As Long, finalLastRow As Long
'
    lastRowOutputArray = UBound(outputArray, 1)
    finalLastRow = lastRowOutputArray + insertedRowCount + firstRow - 1 '1 or firstRow: coz range start from row 10
'
'' Check and delete rows if columns 4 to 6 are empty
    Dim rowToDelete As Long
'
    For rowToDelete = finalLastRow To firstRow Step -1
        If WorksheetFunction.CountBlank(Range("H" & rowToDelete & ":S" & rowToDelete)) = ttlCol Then
            Rows(rowToDelete).EntireRow.Delete
            finalLastRow = finalLastRow - 1 ' Adjust the finalLastRow after deleting a row
        End If
    Next rowToDelete
'
'' custome formating column D & F as D1,D2,D3
    ws.Cells(firstRow, 4).NumberFormat = """D""General"
    ws.Cells(firstRow, 6).NumberFormat = """D""General"
    ws.Cells(firstRow, 4).Offset(1, 0).NumberFormat = """D""General"
    ws.Cells(firstRow, 6).Offset(1, 0).NumberFormat = """D""General"
'
'' carton Number
    ws.Range("D10").Value = 1
    ws.Range("E10").Value = "-"
    ws.Range("F10").Formula = "=T10"
    ws.Range("D11").Formula = "=F10+1"
    ws.Range("E11").Value = "-"
    ws.Range("F11").Formula = "=F10+T11"
    ws.Range("D11:F" & finalLastRow).FillDown
'
'Total value to last row
    ws.Range("T" & finalLastRow + 1).Formula = "=SUM(T10:T" & finalLastRow & ")"
    ws.Range("V" & finalLastRow + 1).Formula = "=SUM(V10:V" & finalLastRow & ")"
    ws.Range("X" & finalLastRow + 1).Formula = "=ROUND(SUM(X10:X" & finalLastRow & "),2)"
    ws.Range("Y" & finalLastRow + 1).Formula = "=ROUND(SUM(Y10:Y" & finalLastRow & "),2)"
    ws.Range("Z" & finalLastRow + 1).Formula = "=ROUND(SUM(Z10:Z" & finalLastRow & "),2)"
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
exitHere:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .EnableAnimations = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
'
    Exit Sub ' Skip error handler if no error occurs
'
ErrorHandler:
    MsgBox "An error occurred: " & Err.Description ' Display error message
    Resume exitHere
End Sub

I could take another swing at the remainder of the code, or anyone else for that matter, If you feel it is necessary after testing the changes and reporting back your results.

 

[Micron]

Don't put an 'On Error GoTo' statement at the very top of your code

I don't agree on principle. I use it often after the Dim section when I intend to include an error handler. It makes the most sense to me to write that directive before doing anything that might raise an error. In the error handler I would attempt to handle the all errors I can think of, and if an error occurs outside of my expectations, I deal with that in the handler as an exception. If users report that unanticipated errors presented the 'unanticipated error message' I could add code to deal with that error.

In makes no sense to me to attempt to do anything that might raise an error and put the directive after that.

 

[johnnyL]

Shall we say opinions vary? Keep in mind I am referring to a blanket 'On error' line of code that extends the entire length of a subroutine.

 

[dmt32]

I am referring to a blanket 'On error' line of code that extends the entire length of a subroutine.

Just wondering if you have confused using

On Error Resume Next

in code which should only be used in in a managed way otherwise it masks all errors which is what you seem to be alluding to in item 6 of in your post #5

with

On Error GoTo [label]

Agree with @Micron this is how in general, to use Error Handling in VBA.

When an error occurs in your code you send the error to a specific label (normally at the bottom of the sub) and handle it accordingly from there where you can either terminate the code or Resume at another point

e.g.

Sub MySub()
    'declare variables
    Dim MyFileName As Variant, MyNumber As Long
    
    'handle errors
    On Error GoTo myerror
    
    'code
    
    'raise error
    Err.Raise 53
    
NextPart:
    MsgBox "Next Part Of Code"
    
    'rest of code
    
myerror:
'report error
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
'continue
    If Err.Number = 53 Then Resume NextPart

End Sub

Hope Helpful

Dave

 

[mehidy1437]

Thank you everybody for your input; I will review each of your suggestions and work on the code.

It may take a few days for me to respond.

Thanks a lot.