Sub CountPhrase()
' Paul Beverley - Version 19.07.22
' Counts this word or phrase

doFormatCount = True
doCountWhole = True

' If nothing is selected, select the current word
If Selection.Start = Selection.End Then
  Selection.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
End If

If InStr(Selection, " ") = 0 Then justOneWord = True

oldStart = Selection.Start
oldEnd = Selection.End

myPhrase = Trim(Selection)
thisBit = Replace(myPhrase, "^", "^^")
thisBit = Replace(thisBit, Chr(13), "^p")
If Right(thisBit, 1) = ChrW(8217) Then thisBit _
     = Left(thisBit, Len(thisBit) - 1)
CR = vbCr: CR2 = CR & CR

' Find whether we're in a footnote
InANote = Selection.Information(wdInFootnote)

If InANote = True Then
  lineJump = 0
  Do
    Selection.MoveUp Unit:=wdLine, count:=1
    lineJump = lineJump + 1
  Loop Until Selection.Information(wdInFootnote) = False
  oldStart = Selection.Start
  oldEnd = Selection.Start
End If

Set rng = ActiveDocument.Content
at = rng.Text
myTot = ActiveDocument.Range.End

ntsText = ""
' Are there any footnotes?
If ActiveDocument.Footnotes.count > 0 Then
  ntsText = ntsText & ActiveDocument.StoryRanges(wdFootnotesStory).Text
  at = at & ntsText
End If

If ActiveDocument.Endnotes.count > 0 Then
  ntsText = ntsText & ActiveDocument.StoryRanges(wdEndnotesStory).Text
  at = at & ntsText
End If

at = Replace(at, Chr(2), "")

' Count all occurences
aTlcase = LCase(at)
myTot = Len(at)

allCount = Len(Replace(aTlcase, LCase(myPhrase), myPhrase & "!")) - myTot

myText = "Any case:  " & Str(allCount) & CR

' Count case sensitively
caseCount = Len(Replace(at, myPhrase, myPhrase & "!")) - myTot

myText = myText & "Exact same case: " & Str(caseCount) & CR2

If doFormatCount = True Then
  oldFind = Selection.Find.Text
  oldReplace = Selection.Find.Replacement.Text
  myTrack = ActiveDocument.TrackRevisions
  ActiveDocument.TrackRevisions = False

  myTotNow = ActiveDocument.Range.End
  ' Count bold italic
  With rng.Find
    .ClearFormatting
    .MatchCase = False
    .Text = myPhrase
    .Font.Italic = True
    .Font.Bold = True
    .Replacement.Text = "^&!"
    .Execute Replace:=wdReplaceAll
  End With
  
  biCount = ActiveDocument.Range.End - myTotNow
  If biCount > 0 Then
    WordBasic.EditUndo
    myText = myText & "Bold italic (main text) : " _
         & Str(biCount) & CR
  End If

  ' Count italic
  With rng.Find
    .ClearFormatting
    .MatchCase = False
    .Font.Italic = True
    .Execute Replace:=wdReplaceAll
  End With
  iCount = ActiveDocument.Range.End - myTotNow
  If iCount > 0 Then
    WordBasic.EditUndo
    myText = myText & "Italic: " _
         & Str(iCount) & CR
  End If

  ' Count bold
  With rng.Find
    .ClearFormatting
    .Font.Bold = True
    .Execute Replace:=wdReplaceAll
  End With
  bCount = ActiveDocument.Range.End - myTotNow
  If bCount > 0 Then
    WordBasic.EditUndo
    myText = myText & "Bold: " & _
         Str(bCount) & CR2
  End If
  With Selection.Find
    .Text = oldFind
    .Replacement.Text = oldReplace
    .MatchWildcards = False
  End With
  ActiveDocument.TrackRevisions = myTrack
End If

If doCountWhole = True Then
  chs = " , . ! : [ ] { } ( ) / \ + "
  chs = chs & ChrW(8220) & " "
  chs = chs & ChrW(8221) & " "
  chs = chs & ChrW(8201) & " "
  chs = chs & ChrW(8222) & " "
  chs = chs & ChrW(8217) & " "
  chs = chs & ChrW(8216) & " "
  chs = chs & ChrW(8212) & " "
  chs = chs & ChrW(8722) & " "
  chs = chs & vbCr & " "
  chs = chs & vbTab & " "
  
  chs = " " & chs & " "
  chs = Replace(chs, "  ", " ")
  chs = Left(chs, Len(chs) - 1)
  
  chars = Split(chs, " ")
  For i = 1 To UBound(chars)
    at = Replace(at, chars(i), " ")
  Next i
  
  ' Count as whole words (case sensitive)
  If justOneWord Then
    p = " " & myPhrase & " "
    at = Replace(at, " ", "  ")
    aTlcase = LCase(at)
    myTot = Len(at)
    wholeWdCaseCount = Len(Replace(at, p, _
         p & "!")) - myTot
    wholeWdNoCaseCount = Len(Replace(aTlcase, LCase(p), _
       p & "!")) - myTot
    myText = myText & "Whole words (Any case):" & _
           Str(wholeWdNoCaseCount) & CR
    myText = myText & "Whole words (Exact same case):" & _
           Str(wholeWdCaseCount) & CR
    titleText = "Characters searched:  """
  Else
    titleText = "Phrase searched:  """
  End If
End If

printResult:
Selection.End = oldStart
Selection.MoveRight Unit:=wdCharacter, count:=1
Selection.Start = oldStart
Selection.End = oldEnd

myText = titleText & myPhrase & """" & CR2 & myText
MsgBox myText, 0, "CountPhrase"
End Sub