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

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