The delete method of the range class failed in vba

0 votes

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
Feb 21, 2023 in Others by Kithuzzz
• 38,010 points
706 views

1 answer to this question.

0 votes

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
answered Feb 21, 2023 by narikkadan
• 63,420 points

Related Questions In Others

0 votes
1 answer
0 votes
1 answer
0 votes
1 answer

Creating a function in excel VBA to calculate the average point in a circular set of numbers

I used the following code to determine ...READ MORE

answered Oct 28, 2022 in Others by narikkadan
• 63,420 points
764 views
0 votes
1 answer

MAX function in Excel: is it possible to provide the range by means of variables?

Try this: =MAX(INDEX(A:A,B2):INDEX(A:A,B3)) READ MORE

answered Nov 15, 2022 in Others by narikkadan
• 63,420 points
286 views
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,740 points
829 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
3,123 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9, 2022 in Others by gaurav
• 23,260 points
418 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,670 points
687 views
0 votes
1 answer

VBA code to select only a table. I am getting a Run-time error '1004'; Method 'Range' of object'_Global' failed

No copy/paste, just direct assignment use.Value Sub Final_Report() ...READ MORE

answered Jan 13, 2023 in Others by narikkadan
• 63,420 points
714 views
0 votes
1 answer

How to programmatically get the values of a spilled Excel range in VBA?

By using the Text property, I was ...READ MORE

answered Mar 23, 2023 in Others by narikkadan
• 63,420 points
609 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP