The following should be faster and more accurate:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range
Set Rng = Selection.Range
With ActiveDocument.Range
  .Font.Hidden = True
    With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Color = Rng.Characters.First.Font.Color
    .Replacement.Text = ""
    .Replacement.Font.Hidden = False
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .Execute Replace:=wdReplaceAll
  End With
  i = .ComputeStatistics(wdStatisticWords)
  Undo 2
End With
Rng.Select
Application.ScreenUpdating = True
MsgBox "There are " & i & " words in the selected colour.", vbInformation
End Sub