Find and Highlight Text

You probably know how you can use Ctrl + F to open the Find dialog box within Excel. Then click the Find All button, then Ctrl + A to select all cells that have the text you want to find.



(If you didn't, you do now)

Or you can give my AET Find and Replace tool a whirl.


Here's some code that based on my addin. (Run the "Test" subroutine)

Private sFindText As String
Private rFoundCells As Range

Private Sub Test()
    Dim rHighlightCell As Range
    
    If TypeName(Selection) <> "Range" Then
        
        MsgBox "Please select a range.", , "Find and Highlight  Text"
        
        Exit Sub
        
    End If
    
    Selection.Font.ColorIndex = xlAutomatic
    
    sFindText = InputBox("Enter the text to find", "Find and Highlight text")
    
    If sFindText = vbNullString Then Exit Sub
    
    Call FindCellsWithValue(False) 'Match Case? Use True or False
    
    If Not rFoundCells Is Nothing Then
        
        For Each rHighlightCell In rFoundCells.Cells
            
            Call HighlightFoundText(rHighlightCell, sFindText, vbRed)
            
            'HighlightFoundText Subroutine
            '------------------------
            'rHighlightCell = Cell to highlight
            'sFindText = Text to highlight if found
            'Colour to use (RGB colours etc are okay too)
            
        Next rHighlightCell
        
    Else
        
        MsgBox Chr(34) & sFindText & Chr(34) & " was not found.", , "Find and Highlight Text"
        
    End If
    
    Set rFoundCells = Nothing
    
End Sub

Private Sub FindCellsWithValue(bMatchCase As Boolean)
    Dim sFirstAddress As String
    Dim rFindCell As Range
        
    With Selection
        
        Set rFindCell = .Find(sFindText, LookIn:=xlValues, MatchCase:=bMatchCase)
        
        If Not rFindCell Is Nothing Then
            
            sFirstAddress = rFindCell.AddressLocal
            
            Do
                
                If rFoundCells Is Nothing Then
                    
                    Set rFoundCells = rFindCell
                    
                Else
                    
                    Set rFoundCells = Union(rFindCell, rFoundCells)
                    
                End If
                
                Set rFindCell = .FindNext(rFindCell)
                
            Loop While Not rFindCell Is Nothing And rFindCell.Address <> sFirstAddress
            
        End If
        
    End With
        
    Set rFindCell = Nothing
        
End Sub

Private Sub HighlightFoundText(rCell As Range, sHighlightText As String, varHighlight As Variant)
    Dim iInstances As Integer
    Dim iTimesToHighlight As Long
    Dim iMidStart As Integer
    
    sHighlightText = UCase(sHighlightText)
    
    iInstances = (Len(UCase(rCell.Value)) - Len(Replace$(UCase(rCell.Value), _
        sHighlightText, vbNullString))) / Len(sHighlightText)
    
    iMidStart = 1
    
    For iTimesToHighlight = 1 To iInstances
        
        rCell.Characters(InStr(iMidStart, UCase(rCell.Value), sHighlightText), _
            Len(sHighlightText)).Font.Color = varHighlight
        
        iMidStart = InStr(iMidStart, UCase(rCell.Value), sHighlightText) + 1
        
    Next iTimesToHighlight
    
End Sub

Note that rather loop through all cells in the selection, the code actually replicates how the Find dialog box works, and selects only cells that have the text to find within them. The FindCellsWithValue subroutine is pretty standard code in this sense, and you can find similar examples here and there on the web. (My AET Find and Replace tool uses a version of this technique). The advantage is speed. Much faster to set up a secondary "selection" of cells where the text exists, before running the HighlightFoundText subroutine if you have a lot of cells selected. And the original selection will still be selected once the highlighting has finished. :-)

See you next time.