How can I prevent VBA code, used to draw up a list of unique words from a word document, from slowing down as the document get's longer - vba

Question

I have used some code from the internet, modified slightly for my specific use case, to draw up a list of unique words from a word document, the code works without a problem, but the time to execute the code seems to grow exponentially as the document length increases. Can anyone give me any suggestions to speed up the code when working with very long documents?
Sub UniqueWordList()
Dim wList As New Collection
Dim wrd
Dim chkwrd
Dim sTemp As String
Dim k As Long
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 0
For Each wrd In ActiveDocument.Range.Words
cWrd = cWrd + 1
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating: " & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
k = 0
For Each chkwrd In wList
k = k + 1
If chkwrd = sTemp Then GoTo nw
If chkwrd > sTemp Then
wList.Add Item:=sTemp, Before:=k
GoTo nw
End If
Next chkwrd
wList.Add Item:=sTemp
End If
nw:
Next wrd
sTemp = "There are " & ActiveDocument.Range.Words.Count & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & wList.Count & " unique words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
For Each chkwrd In wList
Selection.TypeText chkwrd & vbCrLf
Next chkwrd
End Sub
After some suggestions I modified my code to use a scripting dictionary, this however does not seem to have solved the problem. Also to answer the concern regarding my message at the end, I understand that the wording is off, what I want is a list of words from the document but each word only once.
Sub UniqueWordListMi()
Dim wList() As String
Dim sTemp As String
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Dim IsInArray As Boolean
Dim arrsize As Long
Dim rra2 As Variant
arrsize = 0
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 1
ReDim Preserve wList(0 To arrsize)
wList(arrsize) = "UNQ"
For Each wrd In ActiveDocument.Range.Words
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating" & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
ReDim Preserve wList(0 To arrsize)
wList(arrsize) = sTemp
arrsize = arrsize + 1
End If
nw:
cWrd = cWrd + 1
Next wrd
Set Dict = CreateObject("scripting.dictionary")
For i = 0 To UBound(wList)
If (Not Dict.Exists(CStr(wList(i)))) Then Dict.Add CStr(wList(i)), wList(i) 'Next i
Next i
rra2 = Dict.Items
sTemp = "There are " & ActiveDocument.Range.Words.Count & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & UBound(wList) & " unique words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
For u = 0 To UBound(rra2)
Selection.TypeText vbCrLf & rra2(u) & vbCrLf
Next u
End Sub

Answer 1

#AlexK beat me to it with a comment on using a Scripting.Dictionary.
Something like this might help
Option Explicit
Public Function CountUniqueWords(ByRef ipRange As Word.Range) As Scripting.Dictionary
Dim myUniqueWords As Scripting.Dictionary
Set myUniqueWords = New Scripting.Dictionary
Dim myPara As Variant
For Each myPara In ipRange.Paragraphs
Dim myWord As Variant
For Each myWord In Split(myPara.Range.Text)
If myUniqueWords.Exists(myWord) Then
myUniqueWords.Item(myWord) = myUniqueWords.Item(myWord) + 1
Else
myUniqueWords.Add myWord, 1
End If
Next
Next
Set CountUniqueWords = myUniqueWords
End Function
Some polishing might be required to meet your specific requirements.
You can't help some increase in processing time as the document gets longer but as the access to the document is limited to paragraphs rather than words is should proceed somewhat faster.

Answer 2

Try the following code. It uses the dictionary directly with the rules of your code.
Note that this will only improve your code. But still, the longer the document will get, the more words need to be checked and the more time it will need. That fact will not change, you can just optimize it by using the dictionary directly but more words need more time to check.
Option Explicit
Sub UniqueWordListMi()
Dim wList As Object
Set wList = CreateObject("scripting.dictionary")
Dim sTemp As String
Dim cWrd As Long
Dim tWrd As Long
Dim nWrd As String
Dim Flag As Boolean
Dim IsInArray As Boolean
Dim arrsize As Long
Dim rra2 As Variant
arrsize = 0
Flag = False
tWrd = ActiveDocument.Range.Words.Count
cWrd = 1
Dim wrd As Variant
For Each wrd In ActiveDocument.Range.Words
If cWrd Mod 100 = 0 Then
Application.StatusBar = "Updating" & (cWrd)
End If
If Flag Then
Flag = False
GoTo nw
End If
If cWrd < tWrd Then
nWrd = ActiveDocument.Words(cWrd + 1)
nWrd = Trim(LCase(nWrd))
End If
sTemp = Trim(LCase(wrd))
If sTemp = "‘" Then
sTemp = sTemp & nWrd
Flag = True
End If
If sTemp Like "*[a-zA-Z]*" Then
If Not wList.Exists(sTemp) Then
wList.Add sTemp, 1
Else
wList.Item(sTemp) = wList.Item(sTemp) + 1
End If
cWrd = cWrd + 1
End If
nw:
Next wrd
sTemp = "There are " & (cWrd - 1) & " words "
sTemp = sTemp & "in the document, before this summary, but there "
sTemp = sTemp & "are only " & wList.Count & " distinct words."
ActiveDocument.Range.Select
Selection.Collapse Direction:=wdCollapseEnd
Selection.TypeText vbCrLf & sTemp & vbCrLf
Dim chkwrd As Variant
For Each chkwrd In wList
Selection.TypeText chkwrd & vbTab & wList.Item(chkwrd) & " times" & vbCrLf
Next chkwrd
End Sub
The following example:
This is an example test where every word is unique except one.
There are 12 words in the document, before this summary, but there are only 11 distinct words.
this 1 times
is 2 times
an 1 times
example 1 times
test 1 times
where 1 times
every 1 times
word 1 times
unique 1 times
except 1 times
one 1 times

Answer 3

With everyone's help and some additional reading, as well as some help from a reddit user this code work's perfectly:
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
Extremely fast and efficient. Thank you everyone!