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

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

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

Answer 2

如果您使用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秒。

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

2 个答案: