У меня есть лист с более чем 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-столбца на что-то вроде «ZZZZZZZZ», а затем снова отсортировать и отфильтровать их, чтобы удалить его за один раз? @CLR Я еще недостаточно знаком с массивами, чтобы предложить такой ответ (установка диапазона в массив, настройка массива и т. д.), но я считаю, что это было бы еще быстрее.
Я пытался помочь OP, используя методы, уже показанные в их коде, а не вводя новые, но да, удаление фильтра, вероятно, будет быстрее.
Означает ли это фильтрацию каждый раз и удаление фильтра блоков?
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
Если вы отсортируете по столбцу K, а затем прокрутите каждое значение
valeurs_a_supprimer
, вы сможете найти верхнюю и нижнюю часть диапазона, чтобы удалить его как блок. Это будет означать максимум 15 удалений блоков вместо потенциально тысяч удалений строк.