VBA for Excel code to find and change formatting of substrings of text within a cell

The code bellow might be a bit faster (I haven't measured it)

What it does:

• Turns off Excel features, as suggested by @Ron (ScreenUpdating, EnableEvents, Calculation)
• Sets the used range and captures the last used column
• Iterates through each column and applies an AutoFilter for each of the words
• If there is more than one visible row (the first one being the header)
  • Iterates through all visible cells in currently auto-filtered column
  • Checks that the cell doesn't contain error & is not empty (this order, distinct checks)
  • When it finds the current filter word makes the changes
  • Moves to the next cell, then next filter word until all search words are done
  • Moves to the next column, repeats above process
• Clears all filters, and turns Excel features back on

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub ShowMatches()
    Dim ws As Worksheet, ur As Range, lc As Long, wrdArr As Variant, t As Double

    t = Timer
    Set ws = Sheet1
    Set ur = ws.UsedRange
    lc = ur.Columns.Count
    wrdArr = Split(ALL_WORDS, ",")
    enableXL False

    Dim c As Long, w As Long, cVal As String, sz As Long, wb As String
    Dim pos As Long, vr As Range, cel As Range, wrd As String

    For c = 1 To lc
        For w = 0 To UBound(wrdArr)
            If ws.AutoFilterMode Then ur.AutoFilter     'clear filters
            wrd = "*" & wrdArr(w) & "*"
            ur.AutoFilter Field:=c, Criteria1:=wrd, Operator:=xlFilterValues
            If ur.Columns(c).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                For Each cel In ur.Columns(c).SpecialCells(xlCellTypeVisible)
                    If Not IsError(cel.Value2) Then
                        If Len(cel.Value2) > 0 Then
                            cVal = cel.Value2:  pos = 1
                            Do While pos > 0
                                pos = InStr(pos, cVal, wrdArr(w), vbTextCompare)
                                wb = Mid(cVal, pos + Len(wrdArr(w)), 1)
                                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                                    sz = Len(wrdArr(w))
                                    With cel.Characters(Start:=pos, Length:=sz).Font
                                        .Bold = True
                                        .Color = -4165632
                                        .Size = 11
                                    End With
                                    pos = pos + sz - 1
                                Else
                                    pos = 0
                                End If
                            Loop
                        End If
                    End If
                Next
            End If
            ur.AutoFilter   'clear filters
        Next
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Private Sub enableXL(Optional ByVal opt As Boolean = True)
    Application.ScreenUpdating = opt
    Application.EnableEvents = opt
    Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub

Your code uses ReDim Preserve in the first loop (twice)

• slight impact on performance for one cell, but for thousands it becomes significant

• ReDim Preserve makes a copy of the initial arr with the new dimension, then deletes the first arr

Also, Selecting and Activating cells should be avoided - most of the times are not needed and slow down execution

Edit

I measured the performance between the 2 versions

Total cells: 3,060; each cell with 15 words, total search terms: 30

Initial code:               Time: 69.797 sec
My Code:                    Time:  3.969 sec
Initial code optimized:     Time:  3.438 sec

Initial code optimized:

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub TestMatches()
    Dim searchTerms As Variant, cel As Range, t As Double

    t = Timer
    enableXL False
    searchTerms = Split(ALL_WORDS, ",")
    For Each cel In Sheet1.UsedRange
        ChangeAllMatches searchTerms, cel
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Public Sub ChangeAllMatches(ByRef terms As Variant, ByRef cel As Range)
    Dim termStart() As Long  'this array holds starting positions of each match
    Dim termLen() As Long    'this array holds lengths of each matching substring
    Dim response As Variant, term As Variant, strt As Variant, pos As Long, i As Long

    If IsError(cel.Value2) Then Exit Sub    'Do not process error
    If Len(cel.Value2) = 0 Then Exit Sub    'Do not process empty cells
    response = cel.Value2
    If Len(response) > 0 Then
        ReDim termStart(1 To Len(response)) As Long 'create arrays large enough
        ReDim termLen(1 To Len(response)) As Long   'to accommodate any matches
        i = 1: Dim wb As String
        'The loop finds the starting position & length of each matched term
        For Each term In terms              'Iterate through each term
            strt = 1
            Do
                pos = InStr(strt, response, term, vbTextCompare) 'Check for match
                wb = Mid(response, pos + Len(term), 1)
                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                    strt = pos + 1          'Keep looking for more substrings
                    termStart(i) = pos      'Add match starting pos to array
                    termLen(i) = Len(term)  'Add match len to array termLen()
                    i = i + 1
                Else
                    pos = 0
                End If
            Loop While pos > 0  'Keep searching until we find no more matches
        Next
        ReDim Preserve termStart(1 To i - 1) 'clean up array
        ReDim Preserve termLen(1 To i - 1)   'remove extra items at the end
        For i = 1 To UBound(termStart) 'Modify matches based on termStart()
            If termStart(i) > 0 Then
                With cel.Characters(Start:=termStart(i), Length:=termLen(i)).Font
                    .Bold = True
                    .Color = -4165632
                    .Size = 11
                End With
            End If
        Next i
    End If
End Sub