Speedup Processing

[howard]

I have data from Col B onwards on sheet "Stocklist' The headers are in row 2. I have written code to delete text "Consignment" in Col Al, but it is rather slow

It would be appreciated if someone could improve this so it runs faster

 Sub Delete_Consignment()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim rng As Range, cell As Range
    Dim rowToDelete As Range

    Set ws = ThisWorkbook.Sheets("Stocklist")

    ' Find last row in Column AL
    lastRow = ws.Cells(ws.Rows.count, 38).End(xlUp).Row

    ' Clean Column AL data: Remove extra spaces & hidden characters
    For Each cell In ws.Range("AL2:AL" & lastRow)
        cell.Value = Application.WorksheetFunction.Trim(Application.WorksheetFunction.Clean(cell.Value))
    Next cell

    With ws
        ' Apply filter starting from Column B
        .Range("B1:AL" & lastRow).AutoFilter Field:=37, Criteria1:="*Consignment*"

        ' Check if there are visible data rows before trying to delete
        On Error Resume Next
        Set rng = .AutoFilter.Range.Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        ' If matching rows are found, delete them one by one in reverse order
        If Not rng Is Nothing Then
            For Each rowToDelete In rng.Areas
                rowToDelete.EntireRow.Delete
            Next rowToDelete
        End If

        ' Turn off AutoFilter
        .AutoFilterMode = False
    End With
End Sub

 

[Alex Blakenburg]

You are looping where you don't need to.
Also your delete row comment says you are deleting in reverse order but the For Each loop only goes in one direction being top to bottom.
Try this:

 Sub Delete_Consignment()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim rng As Range, cell As Range
    Dim rowToDelete As Range

    Set ws = ThisWorkbook.Sheets("Stocklist")

    ' Find last row in Column AL
    lastRow = ws.Cells(ws.Rows.Count, 38).End(xlUp).Row

    With ws.Range("AL2:AL" & lastRow)
        .Value = Application.Trim(Application.Clean(.Value))
    End With

    With ws
        ' Apply filter starting from Column B
        .Range("B1:AL" & lastRow).AutoFilter Field:=37, Criteria1:="*Consignment*"

        ' Check if there are visible data rows before trying to delete
        On Error Resume Next
        Set rng = .AutoFilter.Range.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        ' If matching rows are found, delete them one by one in reverse order
        If Not rng Is Nothing Then
            rng.EntireRow.Delete
        End If

        ' Turn off AutoFilter
        .AutoFilterMode = False
    End With
End Sub

 

[vcoolio]

Hello Howard,

Further to comments by Alex, as your criteria "Consignment" is being used in a wild card scenario, there's no need to trim the cells first. Also, you mentioned that your headings start in row2 yet you have the autofilter set to row1. Hence, you should just be able to use the Autofilter set to row2 in a simple sub as follows:-

Sub Test()
   
    Dim ws As Worksheet: Set ws = Sheets("StockList")
   
    Application.ScreenUpdating = False
   
        With ws.Range("AL2", ws.Range("AL" & ws.Rows.Count).End(xlUp))
                .AutoFilter 1, "*Consignment*"
                .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
                .AutoFilter
        End With
   
    Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

P.S. I'm assuming that there will always be the criteria "Consignment" prior to filtering.

 

[howard]

Sub Delete_Consignment() Dim ws As Worksheet Dim lastRow As Long Dim rng As Range, cell As Range Dim rowToDelete As Range Set ws = ThisWorkbook.Sheets("Stocklist") ' Find last row in Column AL lastRow = ws.Cells(ws.Rows.Count, 38).End(xlUp).Row With ws.Range("AL2:AL" & lastRow) .Value = Application.Trim(Application.Clean(.Value)) End With With ws ' Apply filter starting from Column B .Range("B1:AL" & lastRow).AutoFilter Field:=37, Criteria1:="*Consignment*" ' Check if there are visible data rows before trying to delete On Error Resume Next Set rng = .AutoFilter.Range.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 ' If matching rows are found, delete them one by one in reverse order If Not rng Is Nothing Then rng.EntireRow.Delete End If ' Turn off AutoFilter .AutoFilterMode = False End With End Sub

Thanks Alex for your code.

I get a run time error

 rng.EntireRow.Delete

 

[howard]

Hello Howard,

Further to comments by Alex, as your criteria "Consignment" is being used in a wild card scenario, there's no need to trim the cells first. Also, you mentioned that your headings start in row2 yet you have the autofilter set to row1. Hence, you should just be able to use the Autofilter set to row2 in a simple sub as follows:-

Sub Test()
   
    Dim ws As Worksheet: Set ws = Sheets("StockList")
   
    Application.ScreenUpdating = False
   
        With ws.Range("AL2", ws.Range("AL" & ws.Rows.Count).End(xlUp))
                .AutoFilter 1, "*Consignment*"
                .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
                .AutoFilter
        End With
   
    Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

Thaks for the amended Code vcoolio. It works 100%

 

[myall_blues]

Alternatively you could use an array.

Sub Delete_Consignment()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long, j As Long, count As Long
    Dim rng As Range, cell As Range
    Dim rowToDelete As Range
    Dim allData As Variant, cleanData As Variant

    Set ws = ThisWorkbook.Sheets("Stocklist")

    ' Find last row in Column AL
    lastRow = Range("AL" & Rows.count).End(xlUp).Row
    allData = Range("B3:AL" & lastRow)
    ReDim cleanData(1 To UBound(allData, 1), 1 To UBound(allData, 2))
    count = 0
    For i = LBound(allData, 1) To UBound(allData, 1)
        If InStr(1, allData(i, UBound(allData, 2)), "Consignment") = 0 Then
            count = count + 1
            allData(i, UBound(allData, 2)) = Trim(allData(i, UBound(allData, 2)))
            For j = 1 To UBound(cleanData, 2)
                cleanData(count, j) = allData(i, j)
            Next j
        End If
    Next i
    Range("B3:AL" & lastRow).ClearContents
    Range("B3").Resize(UBound(cleanData, 1), UBound(cleanData, 2)) = cleanData
End Sub

 

[howard]

Thanks for the Help Murray

 

[vcoolio]

You're welcome Howard. Happy to have been able to assist.

Cheerio,
vcoolio.