在一系列单元格中查找并突出显示特定单词

Question

我想在一系列单元格中找到一个特定的单词，然后用红色突出显示它。为此，我创建了这段代码，但它只在一行上运行并突出显示了所有单元格文本：

Sub Find_highlight()
    Dim ws As Worksheet
    Dim match As Range
    Dim findMe As String

    Set ws = ThisWorkbook.Sheets("MYSHEET")
    findMe = "Background"

    Set match = ws.Range("G3:G1362").Find(findMe)
    match.Font.Color = RGB(255, 0, 0)
End Sub

Answer 1

假设你的 excel 文件看起来像 htis

要为特定单词着色，您必须使用单元格的.Characters 属性。你需要找到单词从哪里开始，然后给它上色。

试试这个

Option Explicit

Sub Sample()
    Dim sPos As Long, sLen As Long
    Dim aCell As Range
    Dim ws As Worksheet
    Dim rng As Range
    Dim findMe As String

    Set ws = ThisWorkbook.Sheets("MYSHEET")

    Set rng = ws.Range("G3:G1362")

    findMe = "Background"

    With rng
        Set aCell = .Find(What:=findMe, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            sPos = InStr(1, aCell.Value, findMe)
            sLen = Len(findMe)

            aCell.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
        End If
    End With
End Sub

输出

Answer 2

我做了一些更改，使其更加通用和准确

Option Explicit
Sub HIGHLIGHTER()
Dim sPos As Long, sLen As Long
Dim rng As Range
Dim findMe As String
Dim i As Integer

Set rng = Application.InputBox(Prompt:= _
    "Please Select a range", _
    Title:="HIGHLIGHTER", Type:=8)
findMe = Application.InputBox(Prompt:= _
    "FIND WHAT?(YOU CAN USE PATTERN USED IN LIKE OPERATOR ", _
    Title:="HIGHLIGHTER", Type:=2)
  For Each rng In rng
    With rng
     If rng.Value Like "*" & findMe & "*" Then
        If Not rng Is Nothing Then
                   For i = 1 To Len(rng.Value)
                   sPos = InStr(i, rng.Value, findMe)
                   sLen = Len(findMe)
                   If (sPos <> 0) Then
                    rng.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                    i = sPos + Len(findMe) - 1
                   End If
                   Next i
       End If
     End If
    End With
   Next rng
End Sub

Answer 3

添加了循环选项

Option Explicit

Sub Macro1()
    Dim sPos As Long, sLen As Long
    Dim aCell As Range
    Dim ws As Worksheet
    Dim rng As Range
    Dim findMe As String

    Set ws = ThisWorkbook.Sheets("Sheet2")

    Set rng = ws.Range("A3:A322")

    findMe = "find"

   For Each rng In Selection
    With rng
        Set aCell = .Find(What:=findMe, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            sPos = InStr(1, aCell.Value, findMe)
            sLen = Len(findMe)

            aCell.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(0, 255, 0)
        End If
    End With
    Next rng
End Sub

Answer 4

我也进行了一些更改以允许同时搜索多个单词。我还去掉了提示并对搜索词进行了硬编码。剩下的唯一问题是使搜索不区分大小写...

Sub HIGHLIGHTER()
Dim sPos As Long, sLen As Long
Dim rng As Range
Dim findMe As String
Dim i As Integer
Dim t As Integer
Dim SearchArray

SearchArray = Array("WORD1", "WORD2")

For t = 0 To UBound(SearchArray)

    Set rng = Range("N2:N10000")
    findMe = SearchArray(t)

    For Each rng In rng
        With rng
            If rng.Value Like "*" & findMe & "*" Then
                If Not rng Is Nothing Then
                    For i = 1 To Len(rng.Value)
                        sPos = InStr(i, rng.Value, findMe)
                        sLen = Len(findMe)

                        If (sPos <> 0) Then
                            rng.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                            rng.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                            i = sPos + Len(findMe) - 1
                        End If
                    Next i
                End If
            End If
        End With
    Next rng

Next t
End Sub