基于在 2 列中找到 2 个不同的单词进行选择

Question

我想使用 Excel VBA 执行以下操作：

1) 在列中查找某个 word_1；

2) 如果在步骤 (1) 中找到 word_1，则向右移动一列并寻找另一个名为 word_2 的单词。如果也找到 word_2，则删除整行。

另一方面，如果没有找到 word_2，则不必删除该行。

一般的想法是在一列中搜索多个单词，如果找到它们，还要仔细检查（为了安全起见）某些附属单词是否在第 2 列中。只有这样才能删除整行。

我做了以下小例子进行测试：

Col1 Col2

xxx xxx
xxx xxx
xxx xxx
findme  acg
xxx xxx
findme  xxx

在此示例中，我在第 1 列中搜索单词“findme”，在第 2 列中搜索相关单词“acg”。如您所见，必须删除第 4 行，因为这两个单词都出现在一行中，与例如相反第 6 行，情况并非如此。

我的最终代码：

    Sub xxx()

    Dim aCell As Range, bCell As Range, aSave As String

    Dim fndOne As String, fndTwo As String
    fndOne = "findme"
    fndTwo = "acg"

    Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With ws

        Set aCell = .Columns(1).Find(What:=fndOne, LookIn:=xlValues, _
            lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then

            aSave = aCell.Address

            Do

                If LCase(.Cells(aCell.row, 2).Value) Like Chr(42) & fndTwo & Chr(42) Then

                    If bCell Is Nothing Then
                        Set bCell = .Range("A" & aCell.row)
                    Else
                        Set bCell = Union(bCell, .Range("A" & aCell.row))
                    End If

                End If

                Set aCell = .Columns(1).FindNext(After:=aCell)

            Loop Until aCell.Address = aSave

        End If

        Set aCell = Nothing
        If Not bCell Is Nothing Then bCell.EntireRow.Delete


    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Answer 1

如果您使用Range.Find method 和Range.FindNext method，在每次删除后删除并检查匹配的记录，您应该能够快速遍历所有可能性。

'delete rows as they are found
Sub delTwofers()
    Dim rw As Long, n As Long, cnt As Long, rng As Range
    Dim v As Long, sALLTERMs As String, vPAIRs As Variant, vTERMs As Variant

    On Error GoTo bm_SafeExit
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Debug.Print Timer

    sALLTERMs = "aa;bb|cc;dd|ee;ff"

    With Worksheets("Sheet1")   'set this worksheet reference properly!
        vPAIRs = Split(LCase(sALLTERMs), Chr(124))
        For v = LBound(vPAIRs) To UBound(vPAIRs)
            vTERMs = Split(vPAIRs(v), Chr(59))
            cnt = Application.CountIfs(.Columns(1), Chr(42) & vTERMs(0) & Chr(42), .Columns(2), Chr(42) & vTERMs(1) & Chr(42))
            rw = 1
            For n = 1 To cnt
                rw = .Columns(1).Find(what:=vTERMs(0), lookat:=xlPart, _
                                      after:=.Columns(1).Cells(rw + (rw <> 1)), MatchCase:=False).Row
                Do While True
                    If LCase(.Cells(rw, 2).Value2) Like Chr(42) & vTERMs(1) & Chr(42) Then
                        .Rows(rw).Delete
                        Exit Do
                    Else
                        rw = .Columns(1).FindNext(after:=.Cells(rw, 1)).Row
                    End If
                Loop
            Next n
        Next v
    End With

    Debug.Print Timer

bm_SafeExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

'collect rows with Union, delete them all at once
Sub delTwofers2()
    Dim rw As Long, n As Long, cnt As Long, rng As Range
    Dim v As Long, sALLTERMs As String, vPAIRs As Variant, vTERMs As Variant

    On Error GoTo bm_SafeExit
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Debug.Print Timer

    sALLTERMs = "aa;bb|cc;dd|ee;ff"

    With Worksheets("Sheet1")   'set this worksheet reference properly!
        vPAIRs = Split(LCase(sALLTERMs), Chr(124))
        For v = LBound(vPAIRs) To UBound(vPAIRs)
            vTERMs = Split(vPAIRs(v), Chr(59))
            cnt = Application.CountIfs(.Columns(1), Chr(42) & vTERMs(0) & Chr(42), .Columns(2), Chr(42) & vTERMs(1) & Chr(42))
            rw = 1
            For n = 1 To cnt
                rw = .Columns(1).Find(what:=vTERMs(0), lookat:=xlPart, _
                                      after:=.Columns(1).Cells(rw), MatchCase:=False).Row
                Do While True
                    If LCase(.Cells(rw, 2).Value2) Like Chr(42) & vTERMs(1) & Chr(42) Then
                        If rng Is Nothing Then
                            Set rng = .Cells(rw, 1)
                        Else
                            Set rng = Union(rng, .Cells(rw, 1))
                        End If
                        Exit Do
                    Else
                        rw = .Columns(1).FindNext(after:=.Cells(rw, 1)).Row
                    End If
                Loop
            Next n
        Next v
    End With

    Debug.Print Timer  'check timer before deleting discontiguous rows
    If Not rng Is Nothing Then _
        rng.EntireRow.Delete

    Debug.Print Timer

bm_SafeExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

通过首先检查确保有什么要删除，可以避免一些错误控制；您只需要找到您知道存在的双重匹配条件的条目。

附录：删除不连续行的集合非常耗时。上面的第二个例程 (delTwofers2) 比在找到行时删除行的例程慢 5%。 25,000 个值，755 个随机删除 - 第一个需要 3.60 秒；后者为 3.75 秒。

Answer 2

此代码使用您的条件将过滤器应用于已用范围的前两列。然后它会删除可见的行：

Sub DeleteSelected()
Dim RangeToFilter As Excel.Range

Set RangeToFilter = ActiveSheet.UsedRange
With RangeToFilter
    .AutoFilter Field:=1, Criteria1:="find me"
    .AutoFilter Field:=2, Criteria1:="access granted"
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
End With
End Sub