I want to delete all the rows containing the word "Resigned" only in column O.
This is my code below to process 331,000 rows. Is it the most effective or fast way to do it?
Sub Delete Resigned ()
Dim i as Integer
For i = Range("O" & Rows.Count).End(xlUp).Row To 1 Step -1
If Instr(1, Cells(i, 3), "Resigned") <> 0 Then
Cells(i,3).EntireRow.Delete
End If
Next i
End Sub
Thanks in advance to the community!
CodePudding user response:
Delete Hundreds of Thousands of Criteria Rows
- It will take forever if the criteria column is not sorted.
- It is assumed that the data is in table format i.e. in a contiguous range (no empty rows or columns) with one row of headers.
- This solution will insert a helper column with an ascending integer sequence. Then it will sort the range by the criteria column, filter it, delete the critical rows (they are now in a contiguous range) and finally sort by and delete the helper column.
- It took less than 30 seconds for 1M rows and 26 columns with about 350k matching rows on my machine. Your feedback on its efficiency is most welcome.
Sub DeleteResigned()
Dim dt As Double: dt = Timer
Const FirstCriteriaCellAddress As String = "O1"
Const Criteria As String = "Resigned"
Application.ScreenUpdating = False
' Reference the worksheet and remove any filters.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.FilterMode Then ws.ShowAllData
' Reference the range.
Dim fCell As Range: Set fCell = ws.Range(FirstCriteriaCellAddress)
Dim rg As Range: Set rg = fCell.CurrentRegion
' Calculate the column index.
Dim cIndex As Long: cIndex = fCell.Column - rg.Column 1
With rg.Columns(cIndex)
' Check if any criteria.
If Application.CountIf(.Resize(.Rows.Count - 1).Offset(1), Criteria) _
= 0 Then
Application.ScreenUpdating = True
MsgBox "No criteria found", vbExclamation
Exit Sub
End If
' Insert a helper column containing an ascending integer sequence.
.Insert xlShiftToRight, xlFormatFromRightOrBelow
With .Offset(, -1)
.NumberFormat = 0
.Value = ws.Evaluate("ROW(" & .Address & ")")
End With
End With
' Sort the range by the criteria column.
rg.Sort rg.Columns(cIndex 1), xlAscending, , , , , , xlYes
' Reference the data range (no headers).
Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Filter the data of the criteria column.
rg.AutoFilter cIndex 1, Criteria
' Reference the visible data rows of the filtered range and delete them.
Dim vdrg As Range: Set vdrg = drg.SpecialCells(xlCellTypeVisible)
ws.AutoFilterMode = False
vdrg.Delete xlShiftUp
' Sort by and delete the helper column.
rg.Sort rg.Columns(cIndex), xlAscending, , , , , , xlYes
rg.Columns(cIndex).Delete xlShiftToLeft
Application.ScreenUpdating = True
Debug.Print Timer - dt
MsgBox "Rows deleted.", vbInformation
End Sub