The delete method of the range class failed in vba

Question

I want to delete all of the rows in a sheet with 330000+ rows if a specified value is present in the k column fields.

The sorting is effective, but the processing is really slow. When I halt the code, they notify me of the error.

'Tri la colonne F
Columns("F:F").Sort key1:=Range("F1"), order1:=xlAscending, Header:=xlYes

'Supprime les lignes où les cellules de la colonne F sont vides
Dim lastRow As Long
lastRow = Cells(Rows.Count, "F").End(xlUp).Row
For i = lastRow To 3 Step -1
    If IsEmpty(Cells(i, "F")) Then
        Rows(i).Delete
    End If
Next i

'Supprime les lignes où les cellules de la colonne K sont égales à certaines valeurs
Dim valeurs_a_supprimer As Variant
valeurs_a_supprimer = Array("(2020PF OLD) WERNER EGERLAND NEUSEDDIN", "(2020PF OLD) SPEDITION HORST MOSOLF KORNWESTHEIM", "ALBIAS STELLANTIS VO (PFV)", "ATESSA ADJACENT STELLANTIS (PFV)", "BALESI LOCATIONS FIGARI (2020PF)", "CAT AULNAY (2020PF)", "CAT AVRIGNY (2020PF)", "CAT BOURGOGNE CHALON (2020PF)", "CAT BOURGOGNE DIJON (2020PF)", "CAT GUASTICCE (2020PF)", "CAT TORRES DE LA ALAMEDA (2020PF)", "CAT VALE ANA GOMES (2020PF)", "SOGRITA BASTIA (2020PF)", "SOGRITA SARROLA AJACCIO (2020PF)", "TRNAVA STELLANTIS (PFV)") 'Ajouter les valeurs que vous voulez supprimer dans le tableau

lastRow = Cells(Rows.Count, "K").End(xlUp).Row
For i = lastRow To 3 Step -1
    If IsNumeric(Application.Match(Cells(i, "K"), valeurs_a_supprimer, 0)) Then
        Rows(i).Delete
    End If
Next i

Answer 1

Delete Criteria Rows Efficiently

Sub DeleteCriteriaRows()

    Const EMPTY_COL As Long = 6
    Const VALUE_COL As Long = 11
    Const FLAG_STRING As String = "!"

    Dim DeleteStrings(): DeleteStrings = Array( _
        "(2020PF OLD) WERNER EGERLAND NEUSEDDIN", _
        "(2020PF OLD) SPEDITION HORST MOSOLF KORNWESTHEIM", _
        "ALBIAS STELLANTIS VO (PFV)", "ATESSA ADJACENT STELLANTIS (PFV)", _
        "BALESI LOCATIONS FIGARI (2020PF)", "CAT AULNAY (2020PF)", _
        "CAT AVRIGNY (2020PF)", "CAT BOURGOGNE CHALON (2020PF)", _
        "CAT BOURGOGNE DIJON (2020PF)", "CAT GUASTICCE (2020PF)", _
        "CAT TORRES DE LA ALAMEDA (2020PF)", "CAT VALE ANA GOMES (2020PF)", _
        "SOGRITA BASTIA (2020PF)", "SOGRITA SARROLA AJACCIO (2020PF)", _
        "TRNAVA STELLANTIS (PFV)")
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key: For Each Key In DeleteStrings: dict(Key) = Empty: Next Key
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    If ws.FilterMode Then ws.ShowAllData
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' has headers
    Dim rCount As Long: rCount = rg.Rows.Count - 1
    
    Dim drg As Range: Set drg = rg.Resize(rCount).Offset(1) ' no headers
    Dim edrg As Range: Set edrg = drg.Columns(EMPTY_COL)
    Dim vdrg As Range: Set vdrg = drg.Columns(VALUE_COL)
    
    Dim eData(): eData = edrg.Value
    Dim vData(): vData = vdrg.Value
    
    Dim r As Long, IsKept As Boolean, WasFlagged As Boolean
    
    For r = 1 To rCount
        If Not IsEmpty(eData(r, 1)) Then ' not empty
        'If Len(CStr(eData(r, 1))) > 0 Then ' not blank
            If Not dict.Exists(CStr(vData(r, 1))) Then IsKept = True
        End If
        If IsKept Then
            IsKept = False ' reset for the next iteration
        Else
            vData(r, 1) = FLAG_STRING
            If Not WasFlagged Then WasFlagged = True ' only once; never reset
        End If
    Next r
    
    If Not WasFlagged Then
        MsgBox "No values matching the criteria found.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    vdrg.Value = vData
    drg.Sort vdrg, xlAscending, , , , , , xlNo ' It won't take forever...
    rg.AutoFilter VALUE_COL, FLAG_STRING
    
    Dim vrg As Range: Set vrg = drg.SpecialCells(xlCellTypeVisible)
    ws.AutoFilterMode = False
    vrg.Delete xlShiftUp ' ,,, if a single area is being deleted.
    
    drg.Sort edrg, xlAscending, , , , , , xlNo
    
    Application.ScreenUpdating = True
    
    MsgBox "Criteria rows deleted.", vbInformation

End Sub