adjusting code highlight specific words through multiple worksheets

[abdelfattah]

hello
i got this code from the internet i succeed adjusting what i need but remains one thing i would highlight the words through multiple worksheets

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("Tom", "Bob")

For t = 0 To UBound(SearchArray)

    Set rng = Range("B2:c10000")
    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

 

[DanteAmor]

How about

Sub highlight_words_through_sheets()
  Dim sPos As Long, sLen As Long, t As Long, i As Long
  Dim rng As Range, f As Range, sh As Worksheet
  Dim SearchArray As Variant, findMe As String, sCell As String
  '
  SearchArray = Array("Tom", "Bob")
  '
  For Each sh In Sheets
    Set rng = sh.Range("B2:C" & sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row)
    For t = 0 To UBound(SearchArray)
      findMe = SearchArray(t)
      Set f = rng.Find(findMe, , xlValues, xlPart, , , True)
      If Not f Is Nothing Then
        sCell = f.Address
        Do
          For i = 1 To Len(f.Value)
            sPos = InStr(i, f.Value, findMe)
            sLen = Len(findMe)
            If sPos > 0 Then
              f.Characters(sPos, sLen).Font.Color = RGB(255, 0, 0)
              f.Characters(sPos, sLen).Font.Bold = True
              i = sPos + sLen - 1
            End If
          Next i
          Set f = rng.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> sCell
      End If
    Next t
  Next sh
End Sub

 

[abdelfattah]

i would apology for respond delaying , and your adjusting is great you're always in the appointment thanks so much

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.