Wordsコレクションを使って文書内の単語を列挙し、各単語がそれぞれいくつあるのかをカウントするWordマクロで、結果は新しい文書に表形式で出力します。

カウントを行う「CntWord」関数内の検索条件を変更すれば得られる結果も変更されます。

Option Explicit

Public Sub CountDocumentWords()
'文書内の単語を単語ごとにカウントする
  Dim doc As Word.Document
  Dim w As Word.Range
  Dim dic As Object
  Dim itm As Variant
  Dim i As Long
  
  i = 2 '初期化
  Application.ScreenUpdating = False
  Set doc = ActiveDocument
  Set dic = CreateObject("Scripting.Dictionary")
  For Each w In doc.Words
    '単語が重複しないようにDictionaryオブジェクトを使用
    If Not dic.Exists(w.Text) Then
      dic.Add w.Text, w.Text
    End If
  Next
  With Application.Documents.Add
    With .Tables.Add(.Range, 1, 3)
      .Cell(1, 1).Range.Text = ""
      .Cell(1, 2).Range.Text = "単語"
      .Cell(1, 3).Range.Text = "個数"
      For Each itm In dic.Items
        .Rows.Add
        .Cell(i, 1).Range.Text = i - 1
        .Cell(i, 2).Range.Text = itm
        .Cell(i, 3).Range.Text = CntWord(doc, itm)
        i = i + 1
      Next
      'テーブルの装飾
      .AutoFitBehavior wdAutoFitContent
      .Borders.InsideLineStyle = wdLineStyleSingle
      .Borders.OutsideLineStyle = wdLineStyleSingle
      .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      With .Rows(1).Shading
        .Texture = wdTextureNone
        .ForegroundPatternColor = wdColorAutomatic
        .BackgroundPatternColor = 16751103
      End With
    End With
  End With
  Set dic = Nothing
  Set doc = Nothing
  Application.ScreenUpdating = True
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Function CntWord(ByVal doc As Word.Document, ByVal txt As String) As String
'単語数をカウントする
  Dim tmp As String
  Dim ret As String
  Dim r As Word.Range
  Dim cnt As Long
  
  ret = "": cnt = 0 '初期化
  tmp = Replace$(txt, "　", "")
  tmp = Replace$(tmp, " ", "")
  tmp = Replace$(tmp, vbCrLf, "")
  tmp = Replace$(tmp, vbCr, "")
  tmp = Replace$(tmp, vbLf, "")
  If Len(tmp) > 0 Then
    Set r = doc.Range(0, 0)
    With r.Find
      '検索条件は適宜変更
      .ClearFormatting
      .ClearAllFuzzyOptions
      .Text = txt
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchByte = False
      .MatchAllWordForms = False
      .MatchSoundsLike = False
      .MatchWildcards = False
      .MatchFuzzy = False
      Do While .Execute
        cnt = cnt + 1
      Loop
    End With
    Set r = Nothing
    ret = CStr(cnt)
  End If
  CntWord = ret
End Function