How to find out, using VBA, how many replacements Word made during a Find & Replace All

Or: How to find out how many occurrences there are of a particular word in a document

Article contributed by Bart Verbeek and Dave Rado

When you click Replace All in the Find & Replace dialog, Word shows the number of replacements on the Status bar after the operation is completed. To the regret of many it is impossible to query this number in VBA. But that does not mean you cannot determine the number of replacements if you want to. The following VBA code sample does just that. (If you are not familiar with using functions with arguments, see How to cut out repetition and write much less code, by using subroutines and functions that take arguments).

Function CountNoOfReplaces(StrFind As String, StrReplace As String)

Dim NumCharsBefore As Long, NumCharsAfter As Long, LengthsAreEqual As Boolean

    Application.ScreenUpdating = False

    'Check whether the length of the Find and Replace strings are the same; _
    if they are, prefix the replace string with a hash (#)
    If Len(StrFind) = Len(StrReplace) Then
        LengthsAreEqual = True
        StrReplace = "#" & StrReplace
    End If

    'Get the number of chars in the doc BEFORE doing Find & Replace
    NumCharsBefore = ActiveDocument.Characters.Count

    'Do the Find and Replace
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = StrFind
        .Replacement.Text = StrReplace
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With

    'Get the number of chars AFTER doing Find & Replace
    NumCharsAfter = ActiveDocument.Characters.Count

    'Calculate of the number of replacements,
    'and put the result into the function name variable
    CountNoOfReplaces = (NumCharsBefore - NumCharsAfter) / _
            (Len(StrFind) - Len(StrReplace))

    'If the lengths of the find & replace strings were equal at the start, _
    do another replace to strip out the #
    If LengthsAreEqual Then

        StrFind = StrReplace
        'Strip off the hash
        StrReplace = Mid$(StrReplace, 2)

        With Selection.Find
            .Text = StrFind
            .Replacement.Text = StrReplace
            .Execute Replace:=wdReplaceAll
        End With

    End If

    Application.ScreenUpdating = True
    'Free up memory
    ActiveDocument.UndoClear

End Function

You could call it like this:

Sub Test()
MsgBox "Number of replacements: " & CountNoOfReplaces _
(StrFind:="Big", StrReplace:="Bigger"), vbInformation
End Sub

This will work regardless of which string is the longest, and even if the strings do not differ in length.

You could take the same principle further, to count the number of occurrences of a particular word in a document:

Function CountWord(WordToCount As String)

Dim NumCharsBefore As Long, NumCharsAfter As Long

    Application.ScreenUpdating = False

    'Get the number of chars in the doc BEFORE doing Find & Replace
    NumCharsBefore = ActiveDocument.Characters.Count

    'Do the Find and Replace
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = WordToCount
        .Replacement.Text = "#" & WordToCount
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With

    'Get the number of chars AFTER doing Find & Replace
    NumCharsAfter = ActiveDocument.Characters.Count

    'Calculate of the number of replacements,
    'and put the result into the function name variable
    CountWord = NumCharsAfter - NumCharsBefore

    'Undo the replace
    ActiveDocument.Undo
    'Free up memory
    ActiveDocument.UndoClear

    Application.ScreenUpdating = False

End Function

You could call it like this:

Sub Test()

Dim Response As String

    Response = InputBox("Type a word you want to count", _
            "Get number of occurrences of this word")

    MsgBox "There are " & CountWord(Response) & _
             " occurrences of the word '" & Response & _
             "' in this document", vbInformation

End Sub

Note: although it is possible to achieve the same ends by using a counter while you do multiple Finds (or multiple Find & Replaces) one at a time, until nothing more is found, that method is much slower than doing a ReplaceAll as illustrated above.