Sub wordCount()
'
' This macro is not offered as fit for any purpose
' use it at your own risk!
' The macro will create a new page of words.
' The number in brackets is how often it occurs
' The first number is how far apart the words are
' The second is the word number in the text

''''''''''''''''''''''''''''
' I usually run the macro and tghen work up from the end.
' on the basis that any word that appears twice should not be close together.
' I then scan the top of the list for the first non-generic words to pick up over use
' (Yes, I know it isn't the prettiest code. It kind of grew from a simple idea.)
''''''''''''''''''''''''''''
Dim i, n, x, max, ptr, maxword
Dim closei
Dim newText
Dim newDoc
'Dim txtArray()
Dim wordArray()
Dim swordArray()
Dim myword, thisword
Dim howclose(15)
Dim closeat(15)
Dim marker
Dim top
Dim noword
Dim lyword
Dim ingword
Dim thatword
Dim wasword
Dim statsize
Dim WordGap
Dim xxptr
WordGap = 50
 lyword = 0
 ingword = 0
 wasword = 0
 thatword = 0
 statsize = 10
    newText = ""
newDoc = ""
For Each singleLine In ActiveDocument.Paragraphs
    lineText = Trim(UCase(singleLine.Range.Text))          '// parse the text here...
    newText = ""
    max = Len(lineText)
    For i = 1 To max
      c = Mid(lineText, i, 1)
      If (c >= "0" And c <= "9") Or (c >= "A" And c <= "Z") Then
        c = c
      Else
        c = " "
      End If
      newText = newText & c
    Next i
    newText = Trim(newText)
    newDoc = newDoc & " " & newText
Next singleLine
    txtArray = Split(newDoc, " ")
    max = UBound(txtArray)
   noword = max
    ReDim wordArray(noword, 2)
    ReDim swordArray(noword, 2)
    For i = 0 To noword
        wordArray(i, 0) = ""
        swordArray(i, 0) = ""
        wordArray(i, 1) = 0
        swordArray(i, 1) = 0
    Next i
    For i = 0 To max
        myword = Trim(txtArray(i))
        If Trim(myword) <> "" Then
            If Right(myword, 2) = "LY" Then lyword = lyword + 1
            If Right(myword, 3) = "ING" Then ingword = ingword + 1
            If myword = "THAT" Then thatword = thatword + 1
            If myword = "WAS" Then wasword = wasword + 1
            ptr = 0
            While (wordArray(ptr, 0) <> myword) And wordArray(ptr, 1) <> 0
                ptr = ptr + 1
            Wend
            If wordArray(ptr, 0) = myword Then
                wordArray(ptr, 1) = wordArray(ptr, 1) + 1
            Else
                wordArray(ptr, 0) = myword
                wordArray(ptr, 1) = 1
            End If
        End If
     Next i

s = ""
max = 0
top = 0
While wordArray(max, 1) <> 0
 If wordArray(max, 1) > top Then top = wordArray(max, 1)
  max = max + 1
Wend
ptr = 0
While top > 0
  For i = 0 To max
     If wordArray(i, 1) = top Then
        swordArray(ptr, 0) = wordArray(i, 0)
        swordArray(ptr, 1) = top
        ptr = ptr + 1
     End If
  Next i
top = top - 1
Wend
s = ""
s = "Word Analyse Version 1.0 - Gap set to " & WordGap & vbCrLf & vbCrLf
s = s & "Word count " & noword & vbCrLf
s = s & "LY words " & vbTab & lyword & vbCrLf
s = s & "ING words " & vbTab & ingword & vbCrLf
s = s & "THAT words " & vbTab & thatword & vbCrLf
s = s & "WAS words " & vbTab & wasword & vbCrLf

max = 0
top = 0

While swordArray(max, 1) <> 1 ' only show more than "1"
  s = s & "(" & swordArray(max, 1) & ")" & vbTab & " >" & swordArray(max, 0) & "<" & vbCrLf
  If (swordArray(max, 0) <> "") Then
  '' go figure the close stats
  If swordArray(max, 1) > 10 Then statsize = 10 Else statsize = swordArray(max, 1)
    For n = 0 To 10
        howclose(n) = 99999
        closeat(n) = 0
    Next n
    myword = swordArray(max, 0)
    ptr = 0
    For i = 1 To noword
        If ptr > 0 Then ptr = ptr + 1
        thisword = txtArray(i)
        If thisword = myword Then
            If ptr = 0 Then
                ptr = 1
            Else
                closei = 10
                While howclose(closei) > ptr And closei > 0
                    closei = closei - 1
                Wend
      ' make a space
      '
                If howclose(closei) < ptr Then disp = 1 Else disp = 0
                For n = 10 To (closei + 1 + disp) Step -1
                    howclose(n) = howclose(n - 1)
                    closeat(n) = closeat(n - 1)
                Next n
                howclose(closei + disp) = ptr
                closeat(closei + disp) = i
            End If
            ptr = 1
        End If
    Next i
    For i = 0 To statsize
    feeble = myword
    
        ptr = closeat(i)
        If ptr > 0 Then
        
        marker = ""
If ptr > 10 Then xxptr = 10 Else xxptr = ptr
        For n = xxptr To 1 Step -1
            marker = txtArray(ptr) & " " & marker
            ptr = ptr - 1
        Next n
        If (howclose(i) < WordGap) Then
        s = s & vbTab & (howclose(i) - 1) & " " & closeat(i) & " " & marker & vbCrLf
        End If
        End If
    Next i
  End If
 max = max + 1
Wend
Documents.Add
ActiveDocument.Range.Text = (s)

End Sub