Paul,
I like your function! As you know, your use of "Find.Found" shivers my timbers so I try to avoid it. Tinkering with your code, I did notice that it can hiccup if there are color adjacent to each other. This can probably be refined but seems to work:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim StrClr As String
Dim i As Long, oRng As Range, oRngCompare As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Format = True
.Wrap = wdFindContinue
.Font.ColorIndex = wdAuto
.Replacement.Font.Hidden = True
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Wrap = wdFindStop
.Font.Hidden = False
Do While .Execute
With oRng
StrClr = GetClr(.Characters.First.Font.Color, .Characters.First.Font.ColorIndex)
If .Font.ColorIndex <> wdAuto Then
Set oRngCompare = oRng.Duplicate
With oRngCompare
.Collapse wdCollapseStart
.Text = "<" & StrClr & ">"
.Font.ColorIndex = wdAuto
End With
.Start = oRngCompare.End
Set oRngCompare = .Duplicate
oRngCompare.Collapse wdCollapseStart
If Asc(.Characters.Last) = 13 Then
Do While .Characters.Last.Font.Color = .Characters.Last.Next.Font.Color
.End = .End + 1
Loop
End If
With .Duplicate
For i = 1 To .Characters.Count
If .Characters(i).Font.Color = .Characters(1).Font.Color Then
oRngCompare.End = oRngCompare.End + 1
oRngCompare.Select
Else
Exit For
End If
Next i
End With
.End = oRngCompare.End
.Select
.Collapse wdCollapseEnd
.Text = "</" & StrClr & ">"
.Font.ColorIndex = wdAuto
End If
.Collapse wdCollapseEnd
If .End >= ActiveDocument.Range.End - 1 Then Exit Do
End With
Loop
End With
ActiveDocument.Range.Font.Hidden = False
Application.ScreenUpdating = True
End Sub