Find string, change color across all Excel Worksheets

Question

search entire Excel workbook for text string and highlight cell appears to be exactly what I need but I can't get it to work on my Excel workbook. I have hundreds of rows across 10 worksheets. All searched-for Strings (Packet 01, Packet 02, Packet 03, etc) would be in B:8 to row-end on worksheet(1) and B:7 to row-end on the other 9 worksheets (Worksheets are named and the InputBox result for the string would need to be case-sensitive). 45547221 indicates interior color change, but there would be too much color with all strings having cells in different colors, thus changing the string color would be better using font.color.index. Trying the 45547221 code as-is finds it skipping the Do/Loop While code when in step mode.

I would modify the code in 45547221 by adding at a minimum:

Dim myColor As Integer
myColor = InputBox("Enter Color Number (1-56)")

(Configured so I can enter up to 5 FindStrings and 5 ColorIndex numbers as Dim with InputBox(es)) In the Do/Loop While I would change .ColorIndex = myColor

I would like to get this code working as it seems to fit my needs - modified to find string instances across workbook and re-color string instead of cell interior colors and (2) get it to recognize the Do/Loop While code which it isn't now but would apply the ColorIndex number to each string.

---

Public Sub find_highlight()

    'Put Option Explicit at the top of the module and
    'Declare your variables.
    Dim FindString As String
    Dim wrkSht As Worksheet
    Dim FoundCell As Range
    Dim FirstAddress As String
    Dim MyColor As Integer 'Added this

    FindString = InputBox("Enter Search Word or Phrase")
    MyColor = InputBox("Enter Color Number")

    'Use For...Each to cycle through the Worksheets collection.
    For Each wrkSht In ThisWorkbook.Worksheets
        'Find the first instance on the sheet.
        Set FoundCell = wrkSht.Cells.Find( _
            What:=FindString, _
            After:=wrkSht.Range("B1"), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
        'Check it found something.
        If Not FoundCell Is Nothing Then
            'Save the first address as FIND loops around to the start
            'when it can't find any more.
            FirstAddress = FoundCell.Address
            Do
                With FoundCell.Font 'Changed this from Interior to Font
                    .ColorIndex = MyColor
                    '.Pattern = xlSolid
                    '.PatternColorIndex = xlAutomatic 'Deactivated this
                End With
                'Look for the next instance on the same sheet.
                Set FoundCell = wrkSht.Cells.FindNext(FoundCell)
            Loop While FoundCell.Address <> FirstAddress
        End If

    Next wrkSht

End Sub

Answer 1

EDIT: This worked for me on your sample data, using a partial match so you can enter (eg) "Packet 03" and still match.

I like to split out the "find all" function into a separate function: it makes the rest of the logic easier to follow.

Public Sub FindAndHighlight()

    Dim FindString As String
    Dim wrkSht As Worksheet
    Dim FoundCells As Range, FoundCell As Range
    Dim MyColor As Integer 'Added this
    Dim rngSearch As Range, i As Long, rw As Long

    FindString = InputBox("Enter Search Word or Phrase")
    MyColor = InputBox("Enter Color Number")

    'Cycle through the Worksheets
    For i = 1 To ThisWorkbook.Worksheets.Count

        Set wrkSht = ThisWorkbook.Worksheets(i)

        rw = IIf(i = 1, 8, 7) '<<< Row to search on
                              '    row 8 for sheet 1, then 7

        'set the range to search
        Set rngSearch = wrkSht.Range(wrkSht.Cells(rw, "B"), _
                        wrkSht.Cells(Rows.Count, "B").End(xlUp))

        Set FoundCells = FindAll(rngSearch, FindString) '<< find all matches

        If Not FoundCells Is Nothing Then
            'got at least one match, cycle though and color
            For Each FoundCell In FoundCells.Cells
                FoundCell.Font.ColorIndex = CInt(MyColor)
            Next FoundCell
        End If

    Next i

End Sub

'return a range containing all matching cells from rng
Public Function FindAll(rng As Range, val As String) As Range
    Dim rv As Range, f As Range
    Dim addr As String

    'partial match...
    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True) 'case-sensitive
    If Not f Is Nothing Then addr = f.Address()

    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f
        Else
            Set rv = Application.Union(rv, f)
        End If
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop

    Set FindAll = rv
End Function