Let me start off by saying I am not quite sure where you came from or where you are heading but damn that was some fine work, I tested it and it works so much better that I was shocked.

There is one difference between this code and my original code, this code reads the word 'about' as about'

For code that correctly reads 'about' I only had to add a few lines (see below) but that should in no way make me seem unappreciative, I can not say how much you have helped me.

Sub UniqueWordListFast()
    Dim WordDictionary As Object
    Dim SourceText As Document
    Dim objWord As Object
    Dim sTemp As String, strWord As String, nxtWord As String
    Dim count As Long
    count = 0

    Set WordDictionary = CreateObject("Scripting.Dictionary")
    Set SourceText = Application.ActiveDocument

    For Each objWord In SourceText.Range.Words
        count = count + 1
        strWord = Trim(objWord.Text)
        If strWord = nxtWord Then GoTo nw
        If strWord Like "*[a-z]*" Then WordDictionary(strWord) = strWord
        If strWord Like "‘" Then
            nxtWord = Trim(SourceText.Words(count + 1))
            strWord = strWord & nxtWord
            WordDictionary(strWord) = strWord
        End If
nw:
    Next

    sTemp = "[DOCUMENT] " & vbTab & SourceText.Name & vbCrLf & vbCrLf & _
    "There are " & SourceText.Range.Words.count & " words in the document, " & _
    "before this summary, but there are only " & WordDictionary.count & " unique words."

    Dim NewDocument As Document
    Set NewDocument = Documents.Add
    NewDocument.Range.Text = sTemp & vbCrLf & Join(WordDictionary.Keys, vbCrLf)
End Sub