Метод удаления класса диапазона не удался в vba

У меня есть лист с более чем 330000 строк, в котором я хочу удалить все строки, если ячейки столбца k равны определенному значению.

Сортировка работает, но потом она работает вечно. Я останавливаю код, и мне говорят об этой ошибке

Спасибо за помощь !

'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

Если вы отсортируете по столбцу K, а затем прокрутите каждое значение valeurs_a_supprimer, вы сможете найти верхнюю и нижнюю часть диапазона, чтобы удалить его как блок. Это будет означать максимум 15 удалений блоков вместо потенциально тысяч удалений строк.

CLR 20.02.2023 15:52

Было бы быстрее поместить массив в критерии автофильтра, настроить значения K-столбца на что-то вроде «ZZZZZZZZ», а затем снова отсортировать и отфильтровать их, чтобы удалить его за один раз? @CLR Я еще недостаточно знаком с массивами, чтобы предложить такой ответ (установка диапазона в массив, настройка массива и т. д.), но я считаю, что это было бы еще быстрее.

Notus_Panda 20.02.2023 17:38

Я пытался помочь OP, используя методы, уже показанные в их коде, а не вводя новые, но да, удаление фильтра, вероятно, будет быстрее.

CLR 21.02.2023 09:16

Означает ли это фильтрацию каждый раз и удаление фильтра блоков?

Mlamb 21.02.2023 09:46
Преобразование HTML-таблицы в профессиональный документ Excel
Преобразование HTML-таблицы в профессиональный документ Excel
Это самый простой способ создания Excel из HTML-таблицы.
Импорт excel в laravel в базу данных
Импорт excel в laravel в базу данных
Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...
1
4
52
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Эффективное удаление строк критериев (300 КБ)

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

Другие вопросы по теме