Фильтр и удаление строк для определенного столбца, имеющего значение c в строке 1 (заголовок)

Question

У меня есть код ниже, который находит конкретное значение в ячейке, если эта ячейка имеет значение, он удалит эту строку.

  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

Но приведенный выше код хорошо работает, когда количество строк ограничено ( 10K), но когда я хочу удалить строки 40K из 140K, это занимает время.

Как мы можем сократить время?

Примечание. Приведенный выше код работает, только если конкретные значения находятся в столбце A, я хотел бы иметь решение, в котором столбец выбирается на основе значения в заголовке (строка 1). Заголовок для конкретного столбца будет «Поток»

Answer 1

Попробуйте этот код, пожалуйста. Он найдет имя заголовка «Stream» для столбца, содержащего строки, которые будут использоваться, и выполнит работу, только если такой заголовок строки существует. Код комментируется, и я надеюсь, что он будет делать то, что (я понял) он должен:

Sub FindDeleteBisMarkedColumn()
Dim sh As Worksheet, arr As Variant, rng As Range, rngDel As Range
Dim lastRow As Long, lastCol As Long, colSort As Range, colS As Long
Set sh = ActiveSheet 'use here your sheet to be processed

lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column 'last column based on the first row

'Finding the column to be sorted (the one containing the header "Stream":_____________________________________
Set colSort = sh.Range(sh.Range("A1"), sh.Cells(1, lastCol)).Find("Stream") 'the cell keeping the "Stream" header
If colSort Is Nothing Then MsgBox "A column header named ""Stream"" must exist in the first row..." & vbCrLf & _
                                  "It is used to determine the column where the search data exists.": Exit Sub
'_____________________________________________________________________________________________________________

colS = colSort.Column                                     'column number of the column to be sorted
lastRow = sh.Cells(Rows.count, colS).End(xlUp).Row        'last row calculated for column to be sorted

   'Create a new column to reorder the range after sorting________________________________________________________
   sh.Cells(1, lastCol + 1).value = "SortOrder"
   sh.Cells(2, lastCol + 1).value = 1: sh.Cells(3, lastCol + 1).value = 2 'set the list elements to be filled down
   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)) 'define the whole range to be processed
 arr = Array("ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo") 'the array keeping the string to be used

 rng.Sort Key1:=colSort, Order1:=xlAscending, Header:=xlYes    'sorting based on the 'colSort' range

 Dim El As Variant, i As Long, j As Long, firstAddr As String
 Dim lastAddr As String, boolFound As Boolean, iNew As Long

 For Each El In arr                          'iterate between each conditions array elements
    For i = 2 To lastRow                     'iterate between the cells of the 'colSort' range
        If sh.Cells(i, colS).value = El Then 'when first matching cell has been found
            firstAddr = sh.Cells(i, colS).Address: iNew = i 'matching cell 'firstAddr' is defined
            For j = i To lastRow 'iterate on the same 'colSort' range, until the last identic cell
                If sh.Cells(j, colS).value <> sh.Cells(j + 1, colS).value Then 'for the last matching cell
                    lastAddr = sh.Cells(j, colS).Address: boolFound = True: Exit For ''lastAddr' defined
                End If
            Next j
        End If
        If firstAddr <> "" Then              'if the array element has been found
            sh.Range(firstAddr & ":" & lastAddr).EntireRow.Delete 'the range to be deleted is built and deleted
            firstAddr = "": lastAddr = ""    'firstAddr and lastAddr are re initializated
            i = iNew - 1: boolFound = False  'i (the iteration variable) is reinitialized at row after the deletion
        End If
    Next i
 Next
 lastRow = sh.Cells(Rows.count, colS).End(xlUp).Row 'last row is redefined, according to # of rows reamained

 Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol + 1)) 'redefin the sorted area based on 'lastRow'
 rng.Sort Key1:=sh.Cells(1, lastCol + 1), Order1:=xlAscending, Header:=xlYes 'sort the range on the 'SortOrder' col
 sh.Range(sh.Cells(1, lastCol + 1), sh.Cells(lastRow, lastCol + 1)).Clear    'clear of 'SortOrder' column
End Sub