蜗牛之路

项目需求：
sheet1是我们采集到的关键字，

sheet2是要过滤的关键词列表，即只要sheet1的关键词中包含了sheet2的关键词，则删除sheet1表中的关键词。
例如：sheet2中有个关键词“车”，sheet1表中有个关键词“北斗服务车”，则删除sheet1中的“北斗服务车”。

右击sheet1的标签页，在出现的菜单中选择“view code”，然后输入代码：

代码如下：

Sub keywordsfilter()
For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row
Sheets(1).Select
With Range("a2:a65536")
    Set c = .Find(Sheets(2).Cells(i, 1), LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            Cells(c.Row, 1).Delete shift:=xlUp
            Set c = .FindNext()
        Loop While Not c Is Nothing
    End If
End With
Next
MsgBox "over"
End Sub

然后通过“Tools - Macro”菜单就可以使用这个Macro了。

不过推荐另一个代码，执行几千上万行的时候会快一点，而且有删除多少关键字的提示信息。

Sub QQDelData()
Dim i&, j&, Jm&, Arr, Brr, Crr, TM
TM = Timer
Arr = Range([sheet1!A1], [sheet1!A65536].End(xlUp))
Brr = Range([sheet2!A1], [sheet2!A65536].End(xlUp))
ReDim Crr(1 To UBound(Arr), 0)
For i = 1 To UBound(Arr)
    If Arr(i, 1) = "" Then GoTo 101
For j = 1 To UBound(Brr)
    If InStr(" " & Arr(i, 1), Brr(j, 1)) > 1 Then GoTo 101
Next j
    Jm = Jm + 1: Crr(Jm, 0) = Arr(i, 1)
101: Next i
[sheet1!A1:A65536].ClearContents
[sheet1!A1].Resize(Jm) = Crr
MsgBox "共刪除 " & UBound(Arr) - Jm & " 行，使用 " & Timer - TM & " 秒  "
End Sub

执行完的提示：

原载：蜗牛博客
网址：http://www.snailtoday.com
尊重版权，转载时务必以链接形式注明作者和原始出处及本声明。