Try this code please. It determines the last row in A:A, then iterates between the existing values in A:A and creates a new range (rngDel) collecting all cells keeping the necessary to be deleted values. Then, the EntireRow of that range cells are deleted at once:
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
For big ranges try, please the next approach:
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
On my laptop, it took 193875 milliseconds for 100000 rows...
I took this thread like a challenge... I prepared another solution using arrays and an ingenious way to delete rows. It would be the best if it would not exist the string limitation of 255 characters. I tried to overpass this limitation building strings from the reversed array, up to the limit of 255 chars and delete rows in more steps. The code is faster than the previous one, but not semnificative:
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
On my laptop it took 181166 milliseconds for 100000 rows...
Trying to explain to you why the code takes so much time, I had another idea, in order to avoid the discontinuous ranges which kills VBA in terms of time consuming. So, test the next code, please. It will take 2 - 3 seconds...
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
