基于在 2 列中找到 2 个不同单词的选择
Selection based on finding 2 different words in 2 columns
我想使用 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
此代码使用您的条件对所用范围的前两列应用过滤器。然后删除可见行：
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
如果您使用了 Range.Find method and 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秒。
我想使用 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
此代码使用您的条件对所用范围的前两列应用过滤器。然后删除可见行：
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
如果您使用了 Range.Find method and 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秒。