Counting words

[Basr]

In the past someone gave a macro. It should tell how many times each word
appears in the text. The macro is fine but it struggles with blank lines and
if there are more words in one line. Beneath the macro I show an example.

As a matter of fact I want to change the macro in two respects:
1. It must cope with blank lines
2. all words in one line shouls be regarded as one word (phrase)

Can someone give me some help to achieve this.


Sub AWordCount()
Dim myString As String
Dim myWord As String
Dim OutString As String
Dim WordEnd As Long
Dim myStringLen As Long
Dim Start

myString = ActiveDocument.Content.text
' remove optional hyphens:
myString = Replace(myString, Chr(31), "")
' word separators:
myString = Replace(myString, ".", " ")
myString = Replace(myString, ",", " ")
myString = Replace(myString, ";", " ")
myString = Replace(myString, "!", " ")
myString = Replace(myString, "?", " ")
myString = Replace(myString, "/", " ")
myString = Replace(myString, "(", " ")
myString = Replace(myString, ")", " ")
myString = Replace(myString, "[", " ")
myString = Replace(myString, "]", " ")
myString = Replace(myString, ":", " ")
myString = Replace(myString, "=", " ")
myString = Replace(myString, "+", " ")
myString = Replace(myString, "-", " ")
myString = Replace(myString, ".", " ")
myString = Replace(myString, Chr(9), " ")
myString = Replace(myString, Chr(13), " ")
myString = Replace(myString, Chr(34), " ")
myString = Replace(myString, Chr(132), " ")
myString = Replace(myString, Chr(147), " ")
myString = Replace(myString, Chr(148), " ")
myString = Replace(myString, Chr(151), " ")
myString = Replace(myString, Chr(160), " ")
' remove multiple blanks:
myString = Replace(myString, " ", " ")
myString = Replace(myString, " ", " ")
myString = Replace(myString, " ", " ")
myString = " " & myString
' case insensitive (?)
myString = LCase$(myString)
myStringLen = Len(myString)

Do
WordEnd = InStr(2, myString, " ")
myWord = Trim(Left$(myString, WordEnd))
myWord = " " & myWord & " "
myString = Replace(myString, myWord, " ")
OutString = OutString & Trim(myWord) & Chr(9)
OutString = OutString & _
Str((myStringLen - Len(myString)) _
/ (Len(myWord) - 1)) & Chr(13)
myStringLen = Len(myString)
Loop Until Len(myString) = 1

ActiveDocument.Select
Selection.Collapse (wdCollapseEnd)
Selection.InsertAfter OutString
Selection.Sort _
SortFieldType:=wdSortFieldAlphanumeric

End Sub

TEXT EXAMPLE
Monkey

Nut

Mice

Monkey

(blank line)

Nut

Monkey

(blank line)

Nut nut

(blank line)

Blackman, P.

Cat

Dog

RESULTS
Monkey 3

blackman 1

cat 1

dog 1

mice 1

nut 1

nut 3

p 1

Thanks in advance
Marcel