查找並突出顯示單元格區域中的特定單詞

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 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 3

我做了一些變化使之更加通用，準確

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 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