有与数据库里面的关键词全部或部分相同的，可否用VBA一键删无赦

rmajly

    有两列数据：左边一列算数据库，放sheet1里；右边这列待加工，放在sheet2里。

    想实现的目标：右边这一列数据中，如果有与左边数据部分或全部相同的，那把右边这个数据，删无赦！

    比方：右边单元格“张三是好学生”，与左边数据库：“张三”部分相同，那右边这个单元格，删了！

    因为实际数据很多，怕公式太慢，想用VBA实现可否。谢谢！   

aa.zip (6.8 KB, 下载次数: 10)

2023-1-9 23:50 上传

点击文件名下载附件

笨鸟飞不高

aa.zip (17.1 KB, 下载次数: 10)

2023-1-10 09:20 上传

点击文件名下载附件

参考！

3190496160

Sub test()
Dim ar As Variant, br As Variant
Dim arr()
With Sheet2
    r = .Cells(Rows.Count, 5).End(xlUp).Row
    ar = .Range("e1:e" & r)
End With
With Sheet1
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    br = .Range("b1:b" & rs)
    If rs < 2 Then MsgBox "sheet1工作表为空！": End
    ReDim arr(1 To UBound(br), 1 To 1)
    For i = 2 To UBound(br)
        f = 0
        If Trim(br(i, 1)) <> "" Then
            For s = 2 To UBound(ar)
                If InStr(ar(s, 1), br(i, 1)) > 0 Then
                    f = f + 1
                    Exit For
                End If
           Next s
        End If
        If f = 0 Then
            n = n + 1
            arr(n, 1) = br(i, 1)
        End If
    Next i
    .Range("b1:b" & rs) = ""
    If n <> "" Then .[b2].Resize(n, 1) = arr
End With
MsgBox "ok!"
End Sub

3190496160

aa.rar (14.76 KB, 下载次数: 7)

2023-1-10 09:25 上传

点击文件名下载附件

LIUZHU

JS宏方案

LIUZHU

WPS测试，谢谢！

gwjkkkkk

参与一下。。。

rmajly

3190496160 发表于 2023-1-10 09:25
Sub test()
Dim ar As Variant, br As Variant
Dim arr()

谢谢回复，似乎删反了

rmajly

gwjkkkkk 发表于 2023-1-10 18:47
参与一下。。。

谢谢回复！灰常好用！