I would have thought you would just replace your y/x loops with a basic range iteration, along lines of below (only modified existing code where relevant):
Public Sub HighlightFirstOccurrence()
Dim d As Object
Dim rngC As Range
Dim z As Long
Dim s As String
Dim words As Variant
Dim c As Long
Set d = CreateObject("Scripting.Dictionary")
For Each rngC In ActiveSheet.Range("D4:D15000").SpecialCells(xlCellTypeVisible).Cells
s = rngC.Value
If Trim(s) <> "" Then
words = Split(s, " ")
c = 1
For z = 0 To UBound(words)
If Not d.exists(words(z)) Then
d.Add words(z), words(z)
rngC.Characters(Start:=c, Length:=Len(words(z))).Font.Color = RGB(255, 0, 0)
End If
c = c + Len(words(z)) + 1
Next z
End If
Next rngC
Set d = Nothing
End Sub
Bookmarks