Sub PhraseCount()
' Paul Beverley - Version 22.12.22
' Counts each of a list of words/phrases

phraseLenMax = 4
ignoreDoc = "zzSwitchList"

Set testDoc = ActiveDocument
testName = testDoc.Name
allText = testDoc.Content.Text
allTextLC = LCase(allText)

' Find the word list
For Each myDoc In Documents
  If InStr(myDoc.Name, ignoreDoc) = 0 _
       And InStr(myDoc.Name, testName) = 0 Then
    numParas = myDoc.Paragraphs.count + 1
    numWords = myDoc.Content.ComputeStatistics(wdStatisticWords)
    myProfile = numWords / numParas
    If myProfile < phraseLenMax + 1 Then
      Set listDoc = myDoc
      listDoc.Activate
      myResponse = MsgBox("Count items in this list?", vbQuestion _
       + vbYesNoCancel, "PhraseCount")
      If myResponse <> vbYes Then
        If myResponse = vbNo Then
          myResponse = MsgBox("Sorry! This looked list a phrase list." _
          & vbCr & vbCr & _
          "Please close this file and run the macro again.", _
          vbQuestion + vbOKCancel, "PhraseCount")
        End If
        Exit Sub
      End If
      Exit For
    End If
  End If
Next myDoc

Set rngOld = ActiveDocument.Content
Documents.Add
Set rng = ActiveDocument.Content
rng.Text = rngOld.Text
Set resultsDoc = ActiveDocument
myTot = Len(allText)
testDoc.Activate
For Each myPar In resultsDoc.Paragraphs
  testText = Replace(myPar.Range.Text, vbCr, "")
  If Len(testText) > 1 Then
    Set rngTest = testDoc.Content
    myTextTot = rngTest.End
    With rngTest.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "<" & testText & ">"
      .Replacement.Text = "^&!"
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
    End With
    numWholeWds = rngTest.End - myTextTot
    If numWholeWds > 0 Then WordBasic.EditUndo
    itemCount = Len(Replace(allText, testText, testText & "!")) - myTot
    testTextLC = LCase(testText)
    itemCountLC = Len(Replace(allTextLC, testTextLC, _
         testTextLC & "!")) - myTot
    Set rng = myPar.Range
    rng.End = rng.End - 1
    rng.InsertAfter Text:=vbTab & Trim(Str(itemCountLC)) _
         & vbTab & Trim(Str(itemCount)) & vbTab & _
         Trim(Str(numWholeWds))
  End If
Next myPar
resultsDoc.Activate
Selection.TypeText Text:=vbTab & "Insens" & vbTab & "Sens" & _
     vbTab & "Whole" & vbCr
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByTabs
Set tb = ActiveDocument.Tables(1)
tb.AutoFitBehavior (wdAutoFitContent)
tb.Borders(wdBorderTop).LineStyle = wdLineStyleNone
tb.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
tb.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
tb.Borders(wdBorderRight).LineStyle = wdLineStyleNone
tb.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
tb.Borders(wdBorderVertical).LineStyle = wdLineStyleNone
tb.Rows(1).Range.Bold = True
For i = 2 To 4
  tb.Columns(i).Select
  Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Next i
Selection.HomeKey Unit:=wdStory
End Sub