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.
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.
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?
YesSub 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
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
Cheers
Paul Edstein
[Fmr MS MVP - Word]
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
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 = "^& "
Cheers
Paul Edstein
[Fmr MS MVP - Word]
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
Last edited by macropod; 03-18-2018 at 02:19 PM. Reason: Fixed code tagging
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