单元格里面指定关键字自动变色

quqiyuan

代码如下。。。
Sub test_字符多一()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    s = Split("水 工国")
    Set d = CreateObject("scripting.dictionary")
    For i = 0 To UBound(s)
        ss = s(i)
        If ss <> Empty Then
            If Not d.exists(ss) Then
                n = n + 1
                d(ss) = n
            End If
        End If
    Next
    With sht
        r = .Cells(Rows.Count, 3).End(3).Row
        arr = .Range("c1:c" & r)
        .Range("c1:c" & r).Font.ColorIndex = 1
        Key = d.keys
        For i = 1 To UBound(arr)
            sss = arr(i, 1)
            If sss <> Empty Then
                For k = 0 To UBound(Key)
                    x = 1
                    For j = 1 To Len(sss)
                        y = InStr(x, sss, Key(k))
                        If y Then
                            .Cells(i, 3).Characters(y, Len(Key(k))).Font.ColorIndex = 3
                            j = y + Len(Key(k))
                            x = y + Len(Key(k)) + 1
                        Else
                            Exit For
                        End If
                    Next
                Next
            End If
        Next
    End With
    Beep
    Set d = Nothing
End Sub

ba3259878266

quqiyuan 发表于 2024-11-18 08:06
改进下，可以对词组也可以匹配。。。。

老师 谢谢  但是需要设置一个区域    比如  G5:G25  怎么改

quqiyuan

ba3259878266 发表于 2024-11-18 09:09
老师 谢谢  但是需要设置一个区域    比如  G5:G25  怎么改

你这个是什么区域，关键字区域还是数据区域，数据区域就改arr数组那里即可

ba3259878266

quqiyuan 发表于 2024-11-18 09:11
你这个是什么区域，关键字区域还是数据区域，数据区域就改arr数组那里即可

老师 早上好 是关键字区域 怎样改  能设置成自动变色更好

quqiyuan

ba3259878266 发表于 2024-11-18 09:18
老师 早上好 是关键字区域 怎样改  能设置成自动变色更好

修改了一下，仅供参考。。。。

quqiyuan

代码如下。。。。。
Sub test_字符多一()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
'    s = Split("水 工国")
    s = sht.[g5:g25]
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(s)
        ss = s(i, 1)
        If ss <> Empty Then
            If Not d.exists(ss) Then
                n = n + 1
                d(ss) = n
            End If
        End If
    Next
    With sht
        r = .Cells(Rows.Count, 3).End(3).Row
        arr = .Range("c1:c" & r)
        .Range("c1:c" & r).Font.ColorIndex = 1
        Key = d.keys
        For i = 1 To UBound(arr)
            sss = arr(i, 1)
            If sss <> Empty Then
                For k = 0 To UBound(Key)
                    x = 1
                    For j = 1 To Len(sss)
                        y = InStr(x, sss, Key(k))
                        If y Then
                            .Cells(i, 3).Characters(y, Len(Key(k))).Font.ColorIndex = 3
                            j = y + Len(Key(k))
                            x = y + Len(Key(k)) + 1
                        Else
                            Exit For
                        End If
                    Next
                Next
            End If
        Next
    End With
    Beep
    Set d = Nothing
End Su

680926

Sub t()
Dim rng As Range
Dim rng1 As Range
Set rng = Range("c3:c9")
brr = Array("火", "中")
    For i = 0 To UBound(brr)
        k = brr(i)
        For Each rng1 In rng
            For j = 1 To Len(rng1)
                m = Mid(rng1, j, 1)
                If k = m Then
                    rng1.Characters(j, 1).Font.ColorIndex = 3
                End If
            Next
        Next
    Next
End Sub

ba3259878266

680926 发表于 2024-11-18 14:13
Sub t()
Dim rng As Range
Dim rng1 As Range

谢谢老师 已经弄好了