Quickly delete rows in a worksheet
2010-10-16 Worksheets 0 141
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 SubAs 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