Sunday, 19 July 2015

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
        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
                If rFoundCells Is Nothing Then
                    Set rFoundCells = rFindCell
                    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.

No comments :

Post a Comment