VBA判断单元格是否包含某些字符并改色

布塔

请教各位老师，用VBA判断sheet1表的A列中的单元格，如果不包含sheet2中A列的一些关键字，就把sheet1表的A列的单元格标记红色

liulang0808

Sub 按钮1_Click()
   
    arr = Sheets(2).[a1].CurrentRegion
    str1 = ""
    For j = 1 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then str1 = str1 & "|" & arr(j, 1)
    Next j
    If Len(str1) = 0 Then
        MsgBox "表2没有匹配的字符"
        Exit Sub
    End If
    str1 = Mid(str1, 2)
    Set Rng = Nothing
    arr = Sheets(1).[a1].CurrentRegion
    Application.ScreenUpdating = False
    Sheets(1).Select
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = str1
        .ignorecase = True
        For j = 2 To UBound(arr)
            If Not .test(arr(j, 1)) Then
                If Rng Is Nothing Then
                    Set Rng = Cells(j, 1)
                Else
                    Set Rng = Union(Rng, Cells(j, 1))
                End If
            End If
        Next j
    End With
    [a1].CurrentRegion.Interior.ColorIndex = xlNone
    If Not Rng Is Nothing Then Rng.Interior.ColorIndex = 6
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。。

lsdongjh

1. Sub CheckHasKey()
   
2.     Dim sh As Worksheet, lngRow As Long, arr As Variant
   
3.     Dim objReg As Object, strTemp As String, strPat As String
   
4.    
   
5.     strPat = GetPat
   
6.     If strPat = "" Then Exit Sub
   
7.    
   
8.     Set sh = Sheets("Sheet1")
   
9.     lngRow = sh.Range("A" & Rows.Count).End(xlUp).Row
   
10.     If lngRow < 2 Then Exit Sub
    
11.    
    
12.     sh.Range("A1:A" & lngRow).Interior.ColorIndex = 0
    
13.     arr = sh.Range("A1:A" & lngRow)
    
14.     Set objReg = CreateObject("VBScript.RegExp")
    
15.     With objReg
    
16.         .Global = True
    
17.         .Pattern = strPat
    
18.     End With
    
19.    
    
20.     For lngRow = LBound(arr) + 1 To UBound(arr)
    
21.         strTemp = CStr(arr(lngRow, 1))
    
22.         '不含，背景色标红
    
23.         If Not objReg.test(strTemp) Then sh.Range("A" & lngRow).Interior.ColorIndex = 3
    
24.     Next
    
25.    
    
26.     Set objReg = Nothing
    
27.     Set sh = Nothing
    
28. End Sub
    
29. 
    
30. Function GetPat() As String
    
31.     Dim sh As Worksheet, lngRow As Long, arr As Variant
    
32.     Dim strTemp As String, strPat As String
    
33.     Set sh = Sheets("Sheet2")
    
34.     lngRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    
35.     arr = sh.Range("A2:A" & lngRow)
    
36.    
    
37.     For lngRow = LBound(arr) To UBound(arr)
    
38.         strTemp = Trim(CStr(arr(lngRow, 1)))
    
39.         If strTemp <> "" Then strPat = strPat & "|" & strTemp
    
40.     Next
    
41.     GetPat = Mid(strPat, 2)
    
42.     Set sh = Nothing
    
43. End Function

复制代码

A1233515

附件供参考

smiletwo

1. Sub ss()
   
2.    Dim i%, j%, arr, brr, m%
   
3.    arr = Sheet1.Range("A1").CurrentRegion.Value
   
4.    brr = Sheet2.Range("A1").CurrentRegion.Value
   
5.    With Sheet1
   
6.      .Range("A2:A" & UBound(arr)).Interior.ColorIndex = 0
   
7.      For i = 2 To UBound(arr)
   
8.         m = 0
   
9.         For j = 1 To UBound(brr)
   
10.            m = InStr(arr(i, 1), brr(j, 1))
    
11.            If m > 0 Then Exit For
    
12.         Next
    
13.         If m = 0 Then .Range("A" & i).Interior.Color = vbRed
    
14.      Next
    
15.    End With
    
16. End Sub

复制代码

smiletwo

布塔

smiletwo 发表于 2021-2-3 17:54

非常感谢

布塔

liulang0808 发表于 2021-2-3 12:40
Sub 按钮1_Click()
   
    arr = Sheets(2).[a1].CurrentRegion

非常感谢老师

雪之花

smiletwo 发表于 2021-2-3 17:54

为什么我按你的代码测试就不行呢，其余2位老师提供的代码都可以，求解答！