删除 O 列中包含特定单词的所有行的最佳代码？

Question

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!

Answer 1

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 ie 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