How can I count the number of words for a specific colorindex

I am trying to count the number of words for the below color indexes. I have been having trouble identifying which color index this text is.

1. Purple type is whatneeds to be added.
   
2. Red type is what needs tobe removed.

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 3/15/2018
Dim oWord As Range
Dim lngCount As Long
  For Each oWord In ActiveDocument.Range.Words
    If oWord.Font.ColorIndex = wdRed Then
      lngCount = lngCount + 1
    End If
  Next
  MsgBox lngCount
lbl_Exit:
  Exit Sub
End Sub

---

Thank you, that works pretty good for the red font. Is there anyway to count the number of words in purple. Also, I will definitely have to drop by your site. Do you have a section on there for word macro basics?

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 3/15/2018
Dim oWord As Range
Dim lngCount As Long
Dim lngColor As Long
  'Put cursor in word with color you want to count.
  lngColor = Selection.Font.Color
  For Each oWord In ActiveDocument.Range.Words
    Select Case oWord
      Case vbCr, vbTab, Chr(11)
        'Some things (white space) Word thinks are words but they are clearly not.  E.g., pararaph marks, tabs, linebreaks
        'There are others but I can't list them all.
      Case Else
        oWord.Select
        If oWord.Font.Color = lngColor Then
          lngCount = lngCount + 1
        End If
    End Select
  Next
  MsgBox lngCount
lbl_Exit:
  Exit Sub
End Sub

---

Yes

The following should be faster and more accurate:

Code:

---

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

---

Paul,

I tried your code but regardless of how many words were colored i always returns 1.

While not as quick but quicker than the first junk I threw out, this worked:

Code:

---

Sub Demo()
Application.ScreenUpdating = False
Dim lngCount As Long, Rng As Range
Dim lngColor As Long
Dim oRng As Range
  lngColor = Selection.Font.Color
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Color = lngColor
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    Do While .Execute
      If Not oRng Like "[" & vbCr & vbTab & Chr(1) & "]" Then
        lngCount = lngCount + 1
      End If
      oRng.Collapse wdCollapseEnd
      If oRng.End = ActiveDocument.Range.End - 1 Then Exit Do
    Loop
  End With
  Application.ScreenUpdating = True
  MsgBox "There are " & lngCount & " words in the selected colour.", vbInformation
End Sub

---

Quote:

---

Originally Posted by gmaxey

I tried your code but regardless of how many words were colored i always returns 1.

---

I can't see how that's possible unless there's only one word with that particular colour. It certainly doesn't behave the way you described for me.

Paul,

It is certainly strange. If I put the cursor in one (or any) of the red words shown below then the return is 1. They are all colored red Color = 255. However, if I put the cursor in one of the black (automatic) words then the return is 5 as expected.

Using Word 2010.

Try changing:
.Replacement.Text = ""
to:

.Replacement.Text = "^& "

Paul,

That got things closer but then the count was off for "automatic color" text in the sample above. This worked though for both cases. Thanks

Code:

---

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 = "<*>" 'Revised GKM
    .Font.Color = Rng.Characters.First.Font.Color
    .Replacement.Text = "~*~ " 'Revised GKM
    .Replacement.Font.Hidden = False
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchWildcards = True 'Added GKM
    .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

---

Paul,

Very interesting process. With a little tweaking, it can be adapted to return a count of replacements:

Code:

---

Sub CountOccurencesOfReplacements()
Dim lngCount As Long, oRng As Range
  Application.ScreenUpdating = False
  Set oRng = Selection.Range
  With ActiveDocument.Range
    With .Find
      .Format = True
      .Font.Hidden = True
      If .Execute Then
        MsgBox "The document contains text formatted with the hidden font " _
            & "property. This custom procedure can't be used with the existing text."
        Exit Sub
      End If
    End With
    .Font.Hidden = True
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "dogs"
      .Replacement.Text = "men~*~* "
      .Replacement.Font.Hidden = False
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = False
      .Execute Replace:=wdReplaceAll
    End With
    lngCount = .ComputeStatistics(wdStatisticWords)
    With .Find
      .Replacement.ClearFormatting
      .Text = "~*~* "
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
    End With
    .Font.Hidden = False
  End With
  oRng.Select
  Application.ScreenUpdating = True
  MsgBox "There were " & lngCount & " replacements mande.", vbInformation
End Sub

---