Requesting for experts comments suggestion on my vba code

[mehidy1437]

Hello dear,

After trying a lot with the helps of many of you, I have the below code, with this code now I am able to complete the pre-packing list within very short time.
I'm setting up dynamic range three times in the code, because it changing after completing the segment.
Everything is fine so far.

But it takes more than one minutes to complete the task, i run this code for 27 rows.

Could you please check & advise, that things are okay with this code or I need to change something to perform better?

'Option Explicit
Sub CreatPackingList()
    'vba run or not confirmation
Dim chkMsg As String, chkAns As Variant
    chkMsg = "This will create the packing list" & vbNewLine & _
    "Keep one additional blank row, in the range H-S" & vbNewLine & _
    "Size range should be col H-S" & vbNewLine & "T col is ctn qty col & put 1 in T coulmn/row" & vbNewLine & _
    "D-E-F column are carton srl no" & vbNewLine & "Trim column H-S before running this code" 

    chkAns = MsgBox(chkMsg, vbYesNo, "Confirmation Box")
    Select Case chkAns
        Case vbYes
 'vba run or not confirmation
'--------------------------------------------------------------
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .EnableAnimations = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With
On Error Resume Next
'--------------------------------------------------------------
'code here
'--------------------------------------------------------------
Application.DisplayAlerts = False
On Error Resume Next

    Dim ws As Worksheet
    ''Set the active sheet
    Set ws = ActiveSheet
    
    Dim rng As Range
    Dim xNum As Integer
    Dim nThNumber As Double
    Dim nThNumberNoDecimil As Single
    Dim nThNumberNoDecInt As Integer
    Dim coPyRowNThTime As Integer
    Dim totalValue As Integer
    Dim balanceValue As Integer
    Dim cUrrentCellCol As Integer
    Dim cUrrentCellRow As Integer
    Dim leftColNumber As Integer
    Dim rightColNumber As Integer
    Dim rangeRowNb As Integer
    Dim lastRowStar As Long, lastColumnStar As Long
    Dim stRng As Range
    Dim firstRow As Long, lastRowZ As Long
    Dim sStyle As String, sTotal As String
    
    ''Set the search values
    sStyle = "Style"
    sTotal = "Total="
    
    
''''''''''''''''''''''''''''''''''''''create Dynamic Range--1111''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    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
    Dim WorkRng As Range
    Set WorkRng = ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19))
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''
Dim tcdCell As Range
    For Each tcdCell In WorkRng
        ' Check if the cell is not empty
        If Not IsEmpty(tcdCell.Value) Then
            tcdCell.Value = Trim(tcdCell.Value)
            tcdCell.Value = WorksheetFunction.Clean(tcdCell.Value)
        End If
    Next tcdCell
'''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''

rangeRowNb = WorkRng.row
xNum:
 xNum = Application.InputBox("PCs per carton", "Division number", Type:=1)
     
    If xNum = False Then
    Exit Sub   'User canceled
    ElseIf xNum / xNum <> 1 Then
    GoTo xNum
    ElseIf Trim(xNum) = "" Then
    'MsgBox "Input is empty"
    GoTo xNum
    End If
 
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 = rng.Column
    cUrrentCellRow = rng.row

    ''''''''''''''''''''''''''''''''
        If balanceValue > 0 Then
           coPyRowNThTime = 2
                ws.Range(rng.Offset(1, 0), rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                ws.Range(rng.Offset(1, 0), rng.Offset(1, 0)).Value = balanceValue
                ws.Range(rng.Offset(2, 0), rng.Offset(2, 0)).ClearContents
                ws.Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                ws.Cells(cUrrentCellRow, 20).Offset(1, 0).Value = 1

                        If cUrrentCellCol = 8 Then
                            ws.Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                         ElseIf cUrrentCellCol = 19 Then
                            ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                        Else
                            leftColNumber = cUrrentCellCol - 1
                            rightColNumber = cUrrentCellCol + 1
                            ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
                            ws.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
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 18).Offset(2, 0)).EntireRow.Delete
                         End If

        Else
           coPyRowNThTime = 1
                    ws.Range(rng.Offset(1, 0), rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                    ws.Range(rng.Offset(1, 0), rng.Offset(1, 0)).ClearContents
                    'ws.Range(Rng.Offset(0, 1), Rng.Offset(0, 3)).ClearContents
                    'Ctn no at column T
                    ws.Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                            If cUrrentCellCol = 8 Then
                                ws.Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                            ElseIf cUrrentCellCol = 19 Then
                                ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                            Else
                                leftColNumber = cUrrentCellCol - 1
                                rightColNumber = cUrrentCellCol + 1
                                ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                                ws.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
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).EntireRow.Delete
                         End If
             
        End If
    '''''''''''''''''''''''''''''''''''''
  Else
     rng.Value = rng.Value
  End If
Next

'put carton number in column D-F
         ws.Cells(rangeRowNb, 4).Value = 1
         ws.Cells(rangeRowNb, 5).Value = "-"
         ws.Cells(rangeRowNb, 6).Formula = "=" & Cells(rangeRowNb, 20).Address(0, 0) & ""
         ws.Cells(rangeRowNb, 4).Offset(1, 0).Formula = "=" & Cells(rangeRowNb, 6).Address(0, 0) & "+1"
         ws.Cells(rangeRowNb, 5).Offset(1, 0).Value = "-"
         ws.Cells(rangeRowNb, 6).Offset(1, 0).Formula = "=" & Cells(rangeRowNb, 6).Address(0, 0) _
         & "+" & Cells(rangeRowNb, 20).Offset(1, 0).Address(0, 0) & ""

'custome formating column D & F as D1,D2,D3
         ws.Cells(rangeRowNb, 4).NumberFormat = """D""General"
         ws.Cells(rangeRowNb, 6).NumberFormat = """D""General"
         ws.Cells(rangeRowNb, 4).Offset(1, 0).NumberFormat = """D""General"
         ws.Cells(rangeRowNb, 6).Offset(1, 0).NumberFormat = """D""General"
         
 ''''''''''''''''''''''''''''''''''''''create Dynamic Range-2222'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    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 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
    Dim NwWorkRng As Range
    Set NwWorkRng = ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19))
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim lastRow As Long
Dim startRow As Long
Dim lastRow2 As Long
Dim startRow2 As Long
Dim orderNo As String
Dim colorName As String
Dim currentOrder As String
Dim currentColor As String
Dim i As Long
         
'row details
Dim Tr As Long ', Rf As Long, Rl As Long
Tr = NwWorkRng.Rows.Count
startRow = NwWorkRng.Rows(1).row
lastRow = NwWorkRng.Rows.Count + startRow - 1
startRow2 = NwWorkRng.Rows(1).row
lastRow2 = NwWorkRng.Rows.Count + startRow2 - 1
'MsgBox "Row: " & Tr & " " & startRow & " " & lastRow
orderNo = Range("B" & startRow).Value
colorName = Range("G" & startRow).Value

'Loop through the range to find first
For i = startRow + 1 To lastRow
    currentOrder = Range("B" & i).Value
    currentColor = Range("G" & i).Value
    
    If currentOrder = orderNo And currentColor = colorName Then
        lastRow = i
    Else
''''''''''''''''=====================================''''''''''''''''''''''''''''''''''''''''
    Dim cell As Range, moveToCell As Range
    Dim moveTo As Range
    Dim minValue As Double
    
    Set rng = Range(Cells(startRow, 8), Cells(lastRow, 19))
    Set moveTo = Range(Cells(lastRow, 8), Cells(lastRow, 19))
    
   For Each moveToCell In moveTo
        minValue = xNum  ' Set a default value
         For Each cell In rng.Columns(moveToCell.Column - rng.Column + 1).Cells
            If cell.Value <> "" And cell.Value < minValue Then
                minValue = cell.Value
            End If
        Next cell
        If moveToCell.Value = "" Then
             moveToCell.Value = IIf(minValue < xNum, minValue, "")
           Else
              moveToCell.Value = moveToCell.Value
        End If
    Next moveToCell
    
    ' Remove values from cells above
    For Each moveToCell In moveTo
        For Each cell In rng.Columns(moveToCell.Column - rng.Column + 1).Cells
            If cell.Value = moveToCell.Value And cell.row < moveToCell.row Then
                cell.ClearContents
            End If
        Next cell
    Next moveToCell
''''''''''''''''=====================================''''''''''''''''''''''''''''''''''''''''
        orderNo = currentOrder
        colorName = currentColor
        startRow = i
        lastRow = i
    End If
Next i

''''''''''''''''=====================================''''''''''''''''''''''''''''''''''''''''
    Dim rng2 As Range
    Dim cell2 As Range, moveToCell2 As Range
    Dim moveTo2 As Range
    Dim minValue2 As Double
    
    Set rng2 = Range(Cells(startRow, 8), Cells(lastRow, 19))
    Set moveTo2 = Range(Cells(lastRow, 8), Cells(lastRow, 19))
    
   For Each moveToCell2 In moveTo2
        minValue2 = xNum  ' Set a default value
         For Each cell2 In rng2.Columns(moveToCell2.Column - rng2.Column + 1).Cells
            If cell2.Value <> "" And cell2.Value < minValue2 Then
                minValue2 = cell2.Value
            End If
        Next cell2
        If moveToCell2.Value = "" Then
             moveToCell2.Value = IIf(minValue2 < xNum, minValue2, "")
           Else
             moveToCell2.Value = moveToCell2.Value
        End If
    Next moveToCell2
    ' Remove values from cells above
    For Each moveToCell2 In moveTo2
        For Each cell2 In rng2.Columns(moveToCell2.Column - rng2.Column + 1).Cells
            If cell2.Value = moveToCell2.Value And cell2.row < moveToCell2.row Then
                cell2.ClearContents
            End If
        Next cell2
    Next moveToCell2
''''''''''''''''=====================================''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''DeleteEmptyRowsInRange ''''''''''''''''
    Dim rngDel As Range
    Dim row As Range
    Dim firstNonEmptyCell As Range
    Set rngDel = Range(Cells(startRow2, 8), Cells(lastRow2 - 1, 19))
    For Each row In rngDel.Rows
        ' Find the first non-empty cell in the row
        Set firstNonEmptyCell = row.Find("*", LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlNext)
        ' Delete the entire row if no non-empty cell is found
        If firstNonEmptyCell Is Nothing Then
            row.EntireRow.Delete
        End If
    Next row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''create Dynamic Range--3333333''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    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 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
    Dim multiValrng As Range
    Set multiValrng = ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19))
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim rowRange As Range
    Dim targetValue As Long
    Dim currentSum As Long
    Dim cellCount As Integer
    Dim firstColumn As Integer
    Dim lastColumn As Integer, secondLastCol As Integer
    
    'targetValue = 30 ' Change the target value as needed
    targetValue = xNum
    firstColumn = 0
    lastColumn = 0
        
    For Each rowRange In multiValrng.Rows
        Dim uniqueCount As Long
        uniqueCount = WorksheetFunction.CountA(rowRange)
        If uniqueCount > 1 Then
            Dim foundCell As Range
            Set foundCell = rowRange.Find(targetValue, LookIn:=xlValues, LookAt:=xlWhole)
            If Not foundCell Is Nothing Then
                rowRange.EntireRow.Copy
                rowRange.Offset(1).EntireRow.Insert Shift:=xlDown
                rowRange.ClearContents
                foundCell.Value = targetValue
                foundCell.Offset(1).ClearContents
            Else
                    currentSum = 0
                    cellCount = 0
                    firstColumn = 0
                    lastColumn = 0
                    For Each cell In rowRange.Cells
                        If Not IsEmpty(cell.Value) Then
                            If firstColumn = 0 Then
                                firstColumn = cell.Column
                            End If
                            currentSum = currentSum + cell.Value
                            cellCount = cellCount + 1
                            lastColumn = cell.Column
                            secondLastCol = lastColumn - 1
                            If currentSum >= targetValue Then
                                 'Perform the desired calculation here using the sum from firstColumn to secondLastCol
                                Dim result As Long, shortVal As Long, rowVal As Long, getlastColVal As Long
                                result = WorksheetFunction.Sum(ws.Range(ws.Cells(cell.row, firstColumn), ws.Cells(cell.row, secondLastCol)))
                                shortVal = targetValue - result
                                rowVal = WorksheetFunction.Sum(ws.Range(ws.Cells(cell.row, 8), ws.Cells(cell.row, 19)))
                                getlastColVal = ws.Cells(cell.row, lastColumn).Value - shortVal
                                 'Display the result
                                'MsgBox "The sum of " & cellCount & " cells in range " & ws.Cells(cell.row, firstColumn).Address & ":" & ws.Cells(cell.row, lastColumn).Address & " is " & currentSum & "." & vbCrLf & _
                                      ' "The sum from column " & ws.Cells(cell.row, firstColumn).Address & " to " & ws.Cells(cell.row, secondLastCol).Address & " is " & result & "."
                                   If rowVal > targetValue Then
                                        ws.Cells(cell.row, 20).Value = 1
                                        rowRange.EntireRow.Copy
                                        rowRange.Offset(1).EntireRow.Insert Shift:=xlDown
                                        ws.Cells(cell.row, lastColumn).Value = shortVal
                                        ws.Cells(cell.row + 1, lastColumn).Value = getlastColVal
                                        ws.Range(ws.Cells(cell.row + 1, firstColumn), ws.Cells(cell.row + 1, lastColumn - 1)).ClearContents
                                        If lastColumn < 19 Then
                                            ws.Range(ws.Cells(cell.row, lastColumn + 1), ws.Cells(cell.row, 19)).ClearContents
                                        End If
                                  End If
                                Exit For
                            End If
                        End If
                    Next cell
                    If currentSum < targetValue Then
                        'MsgBox "No combination of cells in range " & ws.Cells(rowRange.row, firstColumn).Address & ":" & ws.Cells(rowRange.row, lastColumn).Address & " adds up to " & targetValue & "."
                    End If
            End If
        Else
            ' Row does not contain multiple cell values
            ' Add your desired code here to handle this case
        End If
    Next rowRange
    'carton Number
    lastRowZ = stRng.Find(What:=sTotal, After:=ws.Cells(lastRowStar, lastColumnStar), LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False, searchdirection:=xlNext, searchorder:=xlByRows).row - 2
    Range("D11").Formula = "=F10+1"
    Range("F11").Formula = "=F10+T11"
    'Range("D11:F11").Copy Range("D12:F" & lastRowZ)
    Range("D11:F" & lastRowZ).FillDown
'--------------------------------------------------------------
'code here
'--------------------------------------------------------------
On Error GoTo 0
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .EnableAnimations = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With
Done:
Exit Sub
'-----------------------------------------------------------------
'vba run or not confirmation
    Case vbNo
        GoTo Quit:
    End Select
Quit:
'vba run or not confirmation
End Sub

 

[offthelip]

You could improve your code enormously by rewriting it to use variant arrays instead of accessing the worksheet in a loop. probably 1000 times faster at least.
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
you have got multiple accesses to the worksheet in your loop

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
Since this is major rewrite of your system I can't spare the time to help sorry!!
It is worth learning how to use variant arrays at least for any future projects, because if you do you will probably never have any problems with "slow" VBA. I never bother with turning screenupdating off or any of things you have got in your with application statment because variant arrays make so much difference, as I said usually at least 1000 times faster. For your code I would expect it to be even more since it accesses the worksheet on practially every line in loop

 

[offthelip]

just as an example I have rewritten your first loop which was just clean up the values using variant a varinat array to show you how to convert a bit code

    Set WorkRng = ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19))
    Varray = ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19))  ' load range into a variant array
''''''''''''''''''''''''''''''''''''''create Dynamic Range'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''trim & clean data''''''''''''''''''''''''''''''''''''''''''
Dim tcdCell As Range
 
'    For Each tcdCell In WorkRng
     For i = 1 To UBound(Varray, 1)
       For j = 1 To UBound(Varray, 2)
         ' Check if the cell is not empty
'        If Not IsEmpty(tcdCell.Value) Then
        If Not IsEmpty(Varray(i, j)) Then
 '           tcdCell.Value = Trim(tcdCell.Value)
 '           tcdCell.Value = WorksheetFunction.Clean(tcdCell.Value)
            Varray(i, j) = Trim(varray(i, j))
            Varray(i, j) = WorksheetFunction.Clean(Varray(i, j))
        End If
'    Next tcdCell
       Next j
     Next i
    ' write array back to workhseet
    ws.Range(Cells(firstRow, 8), Cells(lastRowZ, 19)) = Varray

 

[mehidy1437]

@offthelip many thanks for your time to review the code & for the suggestion.

Could you please help me to re-write this portion of code using the variant array?

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 = rng.Column
    cUrrentCellRow = rng.row

    ''''''''''''''''''''''''''''''''
        If balanceValue > 0 Then
           coPyRowNThTime = 2
                ws.Range(rng.Offset(1, 0), rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                ws.Range(rng.Offset(1, 0), rng.Offset(1, 0)).Value = balanceValue
                ws.Range(rng.Offset(2, 0), rng.Offset(2, 0)).ClearContents
                ws.Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                ws.Cells(cUrrentCellRow, 20).Offset(1, 0).Value = 1

                        If cUrrentCellCol = 8 Then
                            ws.Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                         ElseIf cUrrentCellCol = 19 Then
                            ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                        Else
                            leftColNumber = cUrrentCellCol - 1
                            rightColNumber = cUrrentCellCol + 1
                            ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                            ws.Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
                            ws.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
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 18).Offset(2, 0)).EntireRow.Delete
                         End If

        Else
           coPyRowNThTime = 1
                    ws.Range(rng.Offset(1, 0), rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                    ws.Range(rng.Offset(1, 0), rng.Offset(1, 0)).ClearContents
                    'ws.Range(Rng.Offset(0, 1), Rng.Offset(0, 3)).ClearContents
                    'Ctn no at column T
                    ws.Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                            If cUrrentCellCol = 8 Then
                                ws.Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                            ElseIf cUrrentCellCol = 19 Then
                                ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                            Else
                                leftColNumber = cUrrentCellCol - 1
                                rightColNumber = cUrrentCellCol + 1
                                ws.Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                                ws.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
                            ws.Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).EntireRow.Delete
                         End If
             
        End If
    '''''''''''''''''''''''''''''''''''''
  Else
     rng.Value = rng.Value
  End If
Next

 

[offthelip]

Your code appears to be operating on a single worksheet, you continually update the worksheet ( which is why your code is very slow) which each step is working on the state of the worksheet as it is after the previous step. When working with array you need to take a slightly different approach: you define a variant array which captures all of the data you need from worksheet. ( as I have done with Varray in the sample code above) . You then define a separate output variant array which you use to build up the data in the way you want it, copying data from the input array, inserting extra rows, missing out rows from the input data ( similar to deleting a row on the worksheet) , finally when the output array is finished you write it back to the worksheet.

Example:

'define an output arrray
Dim Vout(1 To maxrows, 1 To Maxcols) ' you need to workout what maximum size might be, it doesn't matter if it is too big
Dim iout As Long ' row index for output array

When you loop through a range with a statement such as

For Each tcdCell In WorkRng

This automatically takes account of moving through the rows and the columns, with variant arrays you need to do a double loop to take account of the rows and the columns. Like this:

'    For Each tcdCell In WorkRng
     For i = 1 To UBound(Varray, 1)
       For j = 1 To UBound(Varray, 2)

Note if your array is loaded stating in Cell A1 then the indices of the variant array will tie up with the row and column number of the worksheet, ( this can be very helpful) However if you load your array starting somewhere else e.g.

Inarr=Range(“B3:D10”) ,

then inarr(1,1) corresponds to B3,
inarr(1,3) corresponds to D3, ( note the column is the 2nd index)
inarr(8,3) corresponds to D10

To copy a row from the input to the output, you do something like this:

For k = 1 to ubound(Varray,2)
Vout( iout,k)=Varray(I,k)
Next k
iout=iout+1 ‘ increment the output row

I don’t understand what your code is doing and as I said above I don’t have the time to work through it to find out, specially as I don’t have the actual workbook. I hope this helps to get you started.

 

[mehidy1437]

@offthelip Thanks a lot again for your time. I will go through & shall try to improve my code.