Loop to Find Instances of Font.Color = wdRed and Apply Custom Style

I've got a document that has some text colored red. Sometimes it's just a word, other times a sentence or paragraph. I seem to be able to loop Find.Execute the instances of red font okay. But, I'm not getting consistent results when I try to convert those to a custom Style. It works about 50% of the time.

Here's the code:

Code:

---

Dim r As Range
Dim Fnd As Boolean
Fnd = True
Set r = ActiveDocument.Content
r.Find.ClearFormatting
r.Find.Font.Color = wdColorRed
Do While Fnd = True
    With r.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
    End With
If Fnd = True Then
        r.Select
        Selection.Style = ActiveDocument.Styles("CustTxt")
    End If
Loop

---

There is no need for either a loop or even a macro for this. A simple Find/Replace with the appropriate colour parameter for the Find expression and the 'CustTxt' STyle specified as the Replace parameter is all you need. If you're not finding all instances that way, that suggest some of the red colouring is custom (i.e. not the standard red colour).

Additionally, red colouring that results from Track Changes won't be affected by what you're trying to do.