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

Find and highlight a specific word in a range of cells

提问by Anibel

I want to find a specific word in a range of cells then highlight it in red. To do so I created this code but it just worked on one line and highlighted all the cell text:

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

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

回答by Siddharth Rout

Let's say your excel file looks like htis

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

To color specific word, you have to use the cell's .Charactersproperty. You need to find where does the word start from and then color it.

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

Try this

尝试这个

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

OUTPUT

输出

回答by user4232305

i made some change to be more general and accurate

我进行了一些更改以使其更通用和准确

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

回答by Kyle

I too made some changes to allow for searching multiple words at the same time. I also took away the prompts and hard coded the search words. The only issue left is to make the search non-case sensitive...

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

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

回答by Pradeepta Pradhan

added an option to loop

添加了一个循环选项

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