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