For me personally I can't see any value in tracking how close similar words fall so I'm not going to make time to work on this but I will add some code here that could be used to dramatically speed up the execution.
Hopefully someone will put their hand up and work on a way to make this more efficient and sort out your colouring issue. Macropod himself is less active here nowdays but he may feel like embracing a new challenge if he pops in to have a look around.
The following code collects all the words in the document and records how many times that word appears. You could use this to configure code that ONLY searches for words that occur more than once. This would be way faster.
Code:
Sub GetUniqueWordCounts()
Dim aDict As New Scripting.Dictionary
Dim wrd As Variant, sTemp As String, aKey As Variant
With aDict
For Each wrd In ActiveDocument.Range.Words
sTemp = Trim(LCase(wrd))
If Len(sTemp) > 0 Then
Select Case Asc(sTemp)
Case 97 To 122 'if the word starts with a lowercase letter it is something we are interested in
If aDict.Exists(sTemp) Then
aDict.Item(sTemp) = aDict.Item(sTemp) + 1
Else
aDict.Add sTemp, 1
End If
End Select
End If
Next wrd
End With
For Each aKey In aDict.Keys 'audit the values
Debug.Print aKey, aDict(aKey)
Next aKey
End Sub