Попробуйте этот код, пожалуйста. Он определяет последнюю строку в A: A, затем перебирает существующие значения в A: A и создает новый диапазон (rngDel), собирая все ячейки, сохраняя необходимые для удаления значения. Затем EntireRow из этих ячеек диапазона удаляются сразу:
Sub FindDeleteBis()
Dim sh As Worksheet, lastRow As Long, rngDel As Range, i As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastRow
Select Case sh.Range("A" & i).value
Case "ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo" 'add here whatever string you need
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End Select
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
Для больших диапазонов попробуйте следующий подход:
Sub FindDeleteBisBis()
Dim sh As Worksheet, arr As Variant, rng As Range, rngDel As Range
Dim lastRow As Long, lastCol As Long, arrHeader As Variant
Set sh = ActiveSheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column
arrHeader = sh.Range(sh.Range("A1"), sh.Cells(1, lastCol)).value
Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol))
arr = Array("ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo")
rng.AutoFilter _
field:=1, _
Criteria1:=arr, _
Operator:=xlFilterValues
Set rngDel = rng.SpecialCells(xlCellTypeVisible)
rngDel.EntireRow.Delete xlDown
sh.AutoFilterMode = False
'recuperate the columns header...
sh.Rows(1).Insert
sh.Range("A1").Resize(, lastCol).value = arrHeader
End Sub
На моем ноутбуке это заняло 193875 миллисекунд для 100000 строк ...
Я воспринял этот поток как вызов ... Я подготовил другое решение, используя массивы и оригинальный способ удаления строк. Было бы лучше, если бы не существовало ограничение строки в 255 символов. Я попытался преодолеть это ограничение построения строк из обращенного массива, вплоть до 255 символов, и удалить строки за несколько шагов. Код работает быстрее, чем предыдущий, но не является семплификационным:
Sub FindDeleteBisBisBis()
Dim sh As Worksheet, lastRow As Long, arrInit As Variant, arrFin As Variant
Dim i As Long, arrCond As Variant, k As Long, j As Long, z As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
arrInit = sh.Range("A1:A" & lastRow).value
ReDim arrFin(UBound(arrInit) - 1)
For i = 1 To lastRow
If isOK(arrInit(i, 1)) Then arrFin(k) = i: k = k + 1
Next
If k = 0 Then MsgBox "Sheet already processed...": GoTo final:
ReDim Preserve arrFin(k - 1)
Dim strRows As String: ' strRows = "A1"
For i = k - 1 To 0 Step -1
Restart:
For j = i To i - 1000 Step -1
If j < 0 Then Exit For
If Len(strRows) >= 250 Then Exit For
z = z + 1
If strRows = "" Then
strRows = "A" & arrFin(j)
Else
strRows = strRows & ",A" & arrFin(j)
End If
Next j
sh.Range(strRows).EntireRow.Delete
strRows = "": i = i - z + 1: z = 0: If i < 0 Then Exit For: GoTo Restart
Next i
final:
End Sub
На моем ноутбуке это заняло 181166 миллисекунд для 100000 строк ...
Попытка объяснить вам, почему код занимает так много времени, у меня была другая идея, чтобы избежать прерывистых диапазонов, которые убивают VBA с точки зрения затрат времени. Итак, протестируйте следующий код, пожалуйста. Это займет 2 - 3 секунды ...
Sub FindDeleteBisBisBisBis()
Dim sh As Worksheet, arr As Variant, rng As Range, rngDel As Range
Dim lastRow As Long, lastCol As Long, arrHeader As Variant
Set sh = ActiveSheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column
'Create a new co lumnt to reorder after sorting___________________________
sh.Cells(1, lastCol + 1).value = "SortOrder"
sh.Cells(2, lastCol + 1).value = 1: sh.Cells(3, lastCol + 1).value = 2
sh.Range(sh.Cells(2, lastCol + 1), sh.Cells(3, lastCol + 1)).Select
sh.Range(sh.Cells(2, lastCol + 1), sh.Cells(3, lastCol + 1)).AutoFill _
Destination:=sh.Range(sh.Cells(2, lastCol + 1), sh.Cells(lastRow, lastCol + 1))
'__________________________________________________________________________
Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol + 1))
arr = Array("ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo")
rng.Sort Key1:=sh.Range("A1"), Order1:=xlAscending, Header:=xlYes
Dim El As Variant, i As Long, j As Long, firstAddr As String, lastAddr As String
Dim boolFound As Boolean, iNew As Long
For Each El In arr
For i = 2 To lastRow
If sh.Range("A" & i).value = El Then
firstAddr = sh.Range("A" & i).Address: iNew = i
For j = i To lastRow
If sh.Range("A" & j).value <> sh.Range("A" & j + 1).value Then
lastAddr = sh.Range("A" & j).Address: boolFound = True: Exit For
End If
Next j
End If
If firstAddr <> "" Then
sh.Range(firstAddr & ":" & lastAddr).EntireRow.Delete
firstAddr = "": lastAddr = ""
i = iNew - 1: boolFound = False
End If
Next i
Next
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol + 1))
rng.Sort Key1:=sh.Cells(1, lastCol + 1), Order1:=xlAscending, Header:=xlYes
sh.Range(sh.Cells(1, lastCol + 1), sh.Cells(lastRow, lastCol + 1)).Clear
End Sub