excel - 一次查找和删除

Question

我有一个下面的代码可以在单元格中找到特定的值，如果该单元格具有该值，它将删除该行。

Sub FindDelete()  



Set Rng = Range("A:A")

  Set cellFound = Rng.Find("ca-cns")

  Do While Not cellFound Is Nothing

  cellFound.Select

  Selection.EntireRow.Delete

  Set cellFound = Rng.FindNext

Loop



  Set cellFound = Rng.Find("ca-dtc")

  Do While Not cellFound Is Nothing

  cellFound.Select

  Selection.EntireRow.Delete

  Set cellFound = Rng.FindNext

Loop



  Set cellFound = Rng.Find("ca-ext")

  Do While Not cellFound Is Nothing

  cellFound.Select

  Selection.EntireRow.Delete

  Set cellFound = Rng.FindNext

Loop



  Set cellFound = Rng.Find("ca-ns")

  Do While Not cellFound Is Nothing

  cellFound.Select

  Selection.EntireRow.Delete

  Set cellFound = Rng.FindNext

Loop



  Set cellFound = Rng.Find("ca-ssbo")

  Do While Not cellFound Is Nothing

  cellFound.Select

  Selection.EntireRow.Delete

  Set cellFound = Rng.FindNext

Loop



End Sub

它执行正确，但速度不快且代码太长。这个代码可以考虑吗？

我有 ca-cns 值 50 次，因此整个代码重复 50 次，这使得完成时间更长。（如果我用手一次过滤和删除这些行会很快）

标签： excelvba

Answer 1

请尝试此代码。它确定 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

在我的笔记本电脑上，100000 行花费了193875 毫秒......

我把这个线程当作一个挑战......我准备了另一个使用数组和删除行的巧妙方法的解决方案。如果不存在 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

在我的笔记本电脑上，100000 行需要181166 毫秒...

试图向您解释为什么代码需要这么多时间，我有另一个想法，以避免在耗时方面杀死 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