Quickly delete rows in a worksheet

 2010-10-16    Worksheets    0    301

Normally when you want to delete rows from a worksheet you would create a simple loop that would check if a row should be deleted or not, and then delete each row separately. This works fine as long as you have a small data set or don't have to delete many rows.

Sub DeleteRowsExample()
' may be slow on large data sets, multiple delete operations
Dim r As Long, i As Long
    i = 0
    With Range("A5").CurrentRegion
        For r = .Rows.Count To 1 Step -1
            If .Cells(r, .Columns.Count).Value < 10000 Then
                .Rows(r).EntireRow.Delete
                i = i + 1
            End If
        Next r
    End With
    MsgBox i & " rows deleted!", vbInformation
End Sub
As soon as the data set grows and you have to delete many rows, you will find out that performing multiple delete operations makes your macro use a long time to finish. The example below shows how you can speed up the process by marking the rows you want to delete, sort the data set and then perform only one delete operation.
Sub MarkAndDeleteRowsExample()
' fast on large data sets, only one delete operation
Dim frn As Long, fcn As Long, lrn As Long, lcn As Long
Dim blnDelete As Boolean, lngCount As Long, r As Long
    With Application
        .ScreenUpdating = False
        .Cursor = xlWait
        .Calculation = xlCalculationManual
        .StatusBar = "Please wait..."
    End With
    With Range("A1").CurrentRegion
        frn = .Row
        fcn = .Column
        lrn = frn + .Rows.Count - 1
        lcn = fcn + .Columns.Count - 1
    End With
    Cells(frn, lcn + 1).Formula = "Delete Row?" ' add temporary column caption
    For r = frn + 1 To lrn
        blnDelete = False
        On Error Resume Next
        blnDelete = Range("A" & r).Value < 10000 ' do some validation
        On Error GoTo 0
        Cells(r, lcn + 1).Formula = blnDelete ' add row delete flag
        If blnDelete Then
            lngCount = lngCount + 1 ' count rows to delete
        End If
    Next r
    If lngCount > 0 Then ' found 1 or more rows to delete
        lngCount = QuickDeleteRows(Range("A1").CurrentRegion)
    End If
    Cells(frn, lcn + 1).ClearContents ' remove temporary column caption
    With Application
        .StatusBar = False
        .Calculation = xlCalculationAutomatic
        .Cursor = xlDefault
        .ScreenUpdating = True
    End With
    MsgBox lngCount & " rows deleted!", vbInformation
End Sub

Function QuickDeleteRows(objRange As Range, Optional blnHeader As Boolean = True, _
    Optional blnDeleteEntireRow As Boolean = True) As Long
' the last column in objRange must be populated with True or False, rows containing True will be deleted
Dim r As Long, c As Long, i As Long, lngCount As Long
    QuickDeleteRows = 0 ' count of deleted rows
    If objRange Is Nothing Then Exit Function
    
    With objRange
        If .Parent.ProtectContents Then Exit Function ' the worksheet is protected
        r = .Rows.Count: c = .Columns.Count
        If r < 2 Or c < 2 Then Exit Function

        lngCount = 0 ' count of deleted rows
        ' sort objRange based on the last columns content, rows containing True will end up last in the range
        If blnHeader Then
            .Sort Key1:=.Cells(2, c), Order1:=xlAscending, Header:=xlYes
        Else
            .Sort Key1:=.Cells(1, c), Order1:=xlAscending, Header:=xlNo
        End If
        ' find the first row with True in the last column of objRange
        i = 0
        On Error Resume Next
        i = Application.WorksheetFunction.Match(True, .Columns(c), 0)
        On Error GoTo 0
        If i > 0 Then
            On Error Resume Next
            If blnDeleteEntireRow Then ' delete the entire worksheet row
                .Range(.Cells(i, 1), .Cells(r, c)).EntireRow.Delete
            Else ' delete the rows in objRange only, shift cells below up
                .Range(.Cells(i, 1), .Cells(r, c)).Delete xlShiftUp
            End If
            On Error GoTo 0
            lngCount = r - .Rows.Count ' count of deleted rows (original - current rows count)
        End If
    End With
    QuickDeleteRows = lngCount
End Function