VBA row operations take too long to execute

Question

So I have the script below in Execl VB that goes through the rows and deletes the ones that don't contain a certain keyword.

Sub Main()
    RowsDeleted = 0
    Keyword = "COLA"
    For i = 2 to ActiveSheet.UsedRange.Rows.Count
        If InStr(Cells(i, 1).Value, Keyword) = 0 Then
            Rows(i).Delete
            RowsDeleted = RowsDeleted + 1
            i = i - 1
        End If
    Next i
    MsgBox("Rows Deleted: " & RowsDeleted)
End Sub

The problem is that this script takes a very long time to execute (around 8 minutes for ~73000 entries). Why is that and how would I go about improving it?

Answer 1

no offense to other answer, but this will only help with troubleshooting. what you need to do is remove the the line of code

Rows(i).Delete

inside the (potentially) long running For loop is what is causing the slow down.

you need to re-write it like this...

Sub Main()
    RowsDeleted = 0
    Keyword = "COLA"

    Dim rng As Excel.Range
    Dim arr() As Variant
    Dim str As String
    arr = ActiveSheet.UsedRange
    Dim R As Long

    For R = 1 To UBound(arr, 1) ' First array dimension is rows.
        If InStr(arr(R, 1), Keyword) = 0 Then
            If str <> "" Then
                str = "," & str
            End If
            str = str & arr(R, 1).Address
        End If
    Next R

    Set rng = ActiveSheet.Range(str)
    RowsDeleted = rng.Rows.Count
    rng.Delete

    MsgBox ("Rows Deleted: " & RowsDeleted)

End Sub

Answer 2

It takes ages may due to formulas in your cells that are going to be deleted.

What you should do is to turn off auto calculation and Clear the contents of that row before delete. Also you should start from bottom up!

Try this:

Sub Main()
    Dim lMode As Long

    ' Store initial state of Calculation mode
    lMode = Application.Calculation
    ' Change to Manual Calculation
    Application.Calculation = xlCalculationManual
    ' Disable screen update
    Application.ScreenUpdating = False

    RowsDeleted = 0
    Keyword = "COLA"

    ' Start from bottom up!
    For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
        If InStr(Cells(i, 1).Value, Keyword) = 0 Then
            Rows(i).ClearContents
            Rows(i).Delete
            RowsDeleted = RowsDeleted + 1
        End If
    Next i

    ' Restore screenupdate and calculation mode
    Application.ScreenUpdating = True
    Application.Calculation = lMode

    MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub

Answer 3

Here could be something to look at, It filters Column A for cells <>"Cola" and clears them It then sorts column A so the blank cells in column A are now at the bottom It then deletes the blank rows. Not knowing the setup of the OP's ws, there may have to be adjustments made.

On my sample sheet I use 81,000 rows, when I run the code it takes about 5 seconds.

Sub SomeDeleteCode()
    Dim Rws As Long, Rng As Range, nwRw As Long

    Rws = Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculateManual

    Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*"
    Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
    Rng.ClearContents
    ActiveSheet.AutoFilterMode = 0

    Columns(1).Sort Key1:=Range("A1"), Header:=xlYes
    nwRw = Cells(Rows.Count, "A").End(xlUp).Row

    Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete
    Application.Calculation = xlCalculationAutomatic
End Sub

Answer 4

Amend your code to look like this:

Sub Main()
    On Error Goto ErrHandler
    Application.ScreenUpdating = False

    RowsDeleted = 0
    Keyword = "COLA"
    For i = ActiveSheet.UsedRange.Rows.Count to 2
        If InStr(Cells(i, 1).Value, Keyword) = 0 Then
            Rows(i).Delete
            RowsDeleted = RowsDeleted + 1
            ' i = i - 1 ' -- manually changing the loop counter is a bad idea
        End If
    Next i
    MsgBox("Rows Deleted: " & RowsDeleted)

EndSub:
    Application.ScreenUpdating = True
    exit sub
ErrHandler:
    ' Error handling here
    resume EndSub
End Sub

The error handler is required to ensure that the ScreenUpdating is restored, even in case of an error.