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

[munzolli]

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.




Purple type is whatneeds to be added.

Red type is what needs tobe removed.

[gmaxey]

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

[munzolli]

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?

[gmaxey]

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

[macropod]

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

[gmaxey]

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:


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

[macropod]

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.

[gmaxey]

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.

[macropod]

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

.Replacement.Text = "^& "

[gmaxey]

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


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

[gmaxey]

Paul,

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


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