Sub ProperNounAlyse()
' Paul Beverley - Version 28.06.25
' Analyses similar proper nouns

minLengthCheck = 4

includeAcronyms = True

myLanguage = "English(United Kingdom)"
' myLanguage = "English(United States)"

doUseQuickSort = True

ignoreWords = "Also Being The This There Those Their They Then These That" & _
     " Ever Even Four From Have When Where Will While Were Whole Well Would"

similarChars = "bb,b; b,p; sch,sh; ch,sh; c,k; ph,f; ss,z; s,z;" & _
               " mp,m; ll,l; nn,n; nd,n; nt,n;"

' With non-English languages, you might need to make this False
ignorePlurals = True

keepWholeList = False
keepWholeList = True

myScreenOff = True
CR = vbCr: CR2 = CR & CR
Set FUT = ActiveDocument
doingSeveralMacros = (InStr(FUT.Name, "zzTestFile") + _
     InStr(FUT.Name, "Document") > 0)
If doingSeveralMacros = False Then
  myResponse = MsgBox("    ProperNounAlyse" & CR2 & _
       "Analyse this document?", vbQuestion _
       + vbYesNoCancel, "ProperNounAlyse")
  If myResponse <> vbYes Then Exit Sub
End If
If FUT.Content.Words.Count > 50000 And doUseQuickSort = True Then
  useQuickSort = True
Else
  useQuickSort = False
End If
If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

myDummy = ChrW(222)
For i = 1 To 100
  spcs = " " & spcs
Next i

checkFinalLetters = False
checkFinalLetters = True
' Grey on word only
thisHighlight = wdGray25

doMissingLetter = True
' doMissingLetter = False
' Bold And blue

switchTest = True
' switchTest = False
' double strikethrough

doSimilarLetters = True
' doSimilarLetters = False
' various highlight colours + underline

doVowelTest = True
' doVowelTest = False
' various highlight colours + italic

' These last two tests cycle through these colours:
maxCol = 6
ReDim myCol(maxCol) As Integer
myCol(1) = wdYellow
myCol(2) = wdBrightGreen
myCol(3) = wdTurquoise
myCol(4) = wdRed
myCol(5) = wdPink
myCol(6) = wdGray25
colcode = 0

oldColour = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdGray25
leadDots = " . . . "
title1 = "Proper noun list"
title2 = "Proper noun queries"
convCharsUC = "AAAAAAA.EEEEIIII..OOOOO.OUUUU" & _
     "...aaaaaaa.eeeeiiiio.ooooo.ouuuu......"
convCharsLC = LCase(convCharsUC)
timeStart = Timer

' collect notes text, if any
endText = ""
footText = ""
If FUT.Endnotes.Count > 0 Then
  endText = FUT.StoryRanges(wdEndnotesStory).Text
End If
If FUT.Footnotes.Count > 0 Then
  footText = FUT.StoryRanges(wdFootnotesStory).Text
End If

' collect text in all the textboxes (if any)
Sh = FUT.Shapes.Count
If Sh > 0 Then
  ReDim shText(Sh)
  i = 0
  For Each shp In FUT.Shapes
    If shp.Type <> 24 And shp.Type <> 3 Then
      If shp.TextFrame.HasText Then
        i = i + 1
        shText(i) = shp.TextFrame.TextRange.Text
      End If
    End If
  Next
  shCount = i
End If

' Create various documents
Set rng = FUT.Content

Set firstDoc = Documents.Add
Set fnl = firstDoc.Content

Set allText = Documents.Add
Selection.FormattedText = rng.FormattedText
Selection.Collapse wdCollapseEnd

' Add notes + shape text
Selection.TypeText endText & CR & footText & CR
If shCount > 0 Then
  For i = 1 To shCount
    Selection.TypeText shText(i) & CR
  Next i
End If
'Add dummy name
Selection.TypeText Text:="Aaaaa" & CR
Selection.HomeKey Unit:=wdStory

Set rng = allText.Content
rng.Revisions.AcceptAll
DoEvents
StatusBar = spcs & "Preparing copied file - 1"

' Delete struck-through text
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .MatchWildcards = False
  .Font.StrikeThrough = True
  .Replacement.Text = " "
  .Execute Replace:=wdReplaceAll
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "["
  .MatchWildcards = False
  .Replacement.Text = " "
  .Execute Replace:=wdReplaceAll
End With

' Remove strange unicode characters
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[" & ChrW(&HA000) & "-" & ChrW(&HD6FF) & "]{1,}"
  .MatchWildcards = True
  .Replacement.Text = " "
  .Execute Replace:=wdReplaceAll
End With
DoEvents
StatusBar = spcs & "Preparing copied file - 2"
DoEvents

' Cut all and replace as pure text
Set rng = allText.Content
allJustText = allText.Content.Text
allText.Content.Delete
rng.Text = allJustText
DoEvents
StatusBar = spcs & "Preparing copied file - 3"

' Use qqq for apostrophe
Set rng = allText.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "n" & ChrW(8217) & "t"
  .MatchWildcards = False
  .Replacement.Text = "nqqqt"
  .Execute Replace:=wdReplaceAll
End With

' Use qq for apostrophe
With rng.Find
  .Text = "O'"
  .MatchCase = True
  .Replacement.Text = "Oqqq"
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

' Find initial cap words
DoEvents
StatusBar = spcs & "Preparing copied file - 4"
myChopNum = minLengthCheck - 2
If myChop < 1 Then myChop = 1
myChop = Trim(Str(myChopNum))
myFind = "<[A-Z][a-z][a-zA-Z]{" & myChop & ",}"
If includeAcronyms = True Then myFind = _
     "<[A-Z][a-zA-Z][a-zA-Z]{" & myChop & ",}"
Set rng = allText.Range

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myFind
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = True
  .MatchWholeWord = False
  .Execute
End With

myPNlist = ""
ignoreWords = ignoreWords & " "
Do While rng.Find.Found = True
  myWd = rng.Text
  If InStr(ignoreWords, myWd & " ") = 0 Then _
       myPNlist = myPNlist & myWd & CR
  rng.Collapse wdCollapseEnd
  i = i + 1: If i Mod 100 = 0 Then DoEvents
  rng.Find.Execute
Loop

sortT = Timer
If useQuickSort = True Then
  wordArray = Split(myPNlist, CR)
  For i = 1 To 10
    DoEvents
  Next i
  StatusBar = spcs & "Sorting whole file (QuickSort)"
  Debug.Print "Sorting whole file (QuickSort)"
  ' Sort the array alphabetically
  Call QuickSort(wordArray, LBound(wordArray), UBound(wordArray))
  
  ' Clear the content of the document
  allText.Content.Delete
  
  ' Insert sorted words into the document
  For i = LBound(wordArray) To UBound(wordArray)
    allText.Content.InsertAfter wordArray(i) & CR
  Next i
Else
  For i = 1 To 10
    DoEvents
  Next i
  StatusBar = spcs & "Sorting whole file (simple sort)"
  Debug.Print "Sorting whole file (simple sort)"
  allText.Content.Text = myPNlist
  Set rng = allText.Content
  rng.Sort SortOrder:=wdSortOrderAscending, CaseSensitive:=True
End If
For i = 1 To 10
  DoEvents
Next i
StatusBar = spcs & "Finished sorting"
Debug.Print "Finished sorting"
Debug.Print Timer - sortT

' delete initial blank line
If Len(allText.Paragraphs(1)) < 3 Then _
     allText.Paragraphs(1).Range.Delete
If Len(allText.Paragraphs(1)) < 3 Then _
     allText.Paragraphs(1).Range.Delete

allText.Content.InsertAfter Text:=CR
' Create a frequency for each highlighted word
thisWord = ""
myCount = 0
For Each myPara In allText.Paragraphs
  nextWord = myPara.Range.Words(1)
  If nextWord <> thisWord Then
  ' This is a new word
    If Len(thisWord) > 1 Then
      fnl.InsertAfter Text:=thisWord _
           & leadDots & Trim(Str(myCount)) & CR
    End If
    thisWord = nextWord
    myCount = 1
  Else
    myCount = myCount + 1
  End If
  i = i + 1:  If i Mod 400 = 4 Then DoEvents
Next myPara

allText.Close SaveChanges:=False
' firstDoc.Activate

' Remove blank lines
Set rng = firstDoc.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[^13]{2,}"
  .Wrap = wdFindContinue
  .Replacement.Text = "^p"
  .Forward = True
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With

' Resort case insensitively
Set rng = firstDoc.Content
rng.Sort SortOrder:=wdSortOrderAscending, _
     CaseSensitive:=False

' Delete rubbish from top and bottom of list
Do
  Set rng = firstDoc.Paragraphs(1).Range
  myLen = Len(rng.Text)
  If myLen < 10 Then
    rng.Select
    Selection.Delete
  End If
Loop Until myLen > 9
Do
  lastLine = firstDoc.Paragraphs.Count
  Set rng = firstDoc.Paragraphs(lastLine).Range
  myLen = Len(rng.Text)
  If myLen < 10 Then
    rng.Select
    Selection.Delete
  End If
Loop Until Len(rng.Text) >= 2

' Word list now has freq. count.
Do
  lastLine = firstDoc.Paragraphs.Count
  Set rng = firstDoc.Paragraphs(lastLine).Range
  myLen = Len(rng.Text)
  If myLen < 10 Then
    rng.Select
    Selection.Delete
  End If
Loop Until Len(rng.Text) >= 2

' Create another copy for doing extra tests
Set rng = firstDoc.Content

Set finalList = Documents.Add
finalList.Range.Text = rng.Text

' Prepare data for other tests
numWords = finalList.Paragraphs.Count
For i = 1 To numWords
  aWord = finalList.Paragraphs(i).Range.Words(1)
  n = AscW(aWord)
  thisChar = ChrW(n)
  If n > 129 Then
    If n >= 217 Then aWord = Replace(aWord, thisChar, "U")
    If n >= 210 Then aWord = Replace(aWord, thisChar, "O")
    If n >= 204 Then aWord = Replace(aWord, thisChar, "I")
    If n >= 200 Then aWord = Replace(aWord, thisChar, "E")
    If n >= 192 Then aWord = Replace(aWord, thisChar, "A")
  End If
  allWords = allWords & aWord
  jmp = 100
  If i Mod jmp = 1 Then
    PQ = PQ + 1
    DoEvents
    StatusBar = spcs & _
         "Preparing data for other tests - 1 - " & PQ
    DoEvents
  End If
Next i

' ...for the vowel test below
DoEvents
StatusBar = spcs & "Preparing data for other tests - 2"
DoEvents
noVowelWords = " " & allWords
noVowelWords = Replace(noVowelWords, " A", "_1")
noVowelWords = Replace(noVowelWords, " E", "_2")
noVowelWords = Replace(noVowelWords, " I", "_3")
noVowelWords = Replace(noVowelWords, " O", "_4")
noVowelWords = Replace(noVowelWords, " U", "_5")
noVowelWords = Replace(noVowelWords, " Y", "_6")
For k = 2 To Len(noVowelWords) - 1
  thisChar = Mid(noVowelWords, k, 1)
  n = AscW(thisChar)
  If n > 191 And n < 221 Then
    myNewChar = Mid(convCharsLC, n - 191, 1)
    If myNewChar <> "." Then noVowelWords = _
         Replace(noVowelWords, thisChar, myNewChar)
  End If
Next k
noVowelWords = Replace(noVowelWords, "a", "")
noVowelWords = Replace(noVowelWords, "e", "")
noVowelWords = Replace(noVowelWords, "i", "")
noVowelWords = Replace(noVowelWords, "o", "")
noVowelWords = Replace(noVowelWords, "u", "")
noVowelWords = Replace(noVowelWords, "y", "")
noVowelWords = Replace(noVowelWords, "A", "")
noVowelWords = Replace(noVowelWords, "E", "")
noVowelWords = Replace(noVowelWords, "I", "")
noVowelWords = Replace(noVowelWords, "O", "")
noVowelWords = Replace(noVowelWords, "U", "")
noVowelWords = Replace(noVowelWords, "Y", "")
noVowelWords = Replace(noVowelWords, "_1", " A")
noVowelWords = Replace(noVowelWords, "_2", " E")
noVowelWords = Replace(noVowelWords, "_3", " I")
noVowelWords = Replace(noVowelWords, "_4", " O")
noVowelWords = Replace(noVowelWords, "_5", " U")
noVowelWords = Replace(noVowelWords, "_6", " Y")

' ...for the similar words test
DoEvents
StatusBar = spcs & "Preparing data for other tests - 3"
DoEvents
similarAllWords = " " & LCase(allWords)
similarChars = Replace(similarChars, " ", "")
sChars = Replace(similarChars, " ", "")

Do
  commaPos = InStr(sChars, ",")
  charWas = Left(sChars, commaPos - 1)
  sChars = Mid(sChars, commaPos + 1)
  semicolonPos = InStr(sChars, ";")
  charNew = Left(sChars, semicolonPos - 1)
  sChars = Mid(sChars, semicolonPos + 1)
  similarAllWords = Replace(similarAllWords, charWas, charNew)
Loop Until Len(sChars) < 2

' Changes all the accented characters to non-accented
DoEvents
StatusBar = spcs & "Preparing data for other tests - 4"
DoEvents
sWd = similarAllWords
For k = 1 To Len(sWd) - 1
  thisChar = Mid(sWd, k, 1)
  n = AscW(thisChar)
  myNewChar = "."
  If n > 191 And n < 256 Then
    myNewChar = Mid(convCharsLC, n - 191, 1)
    If myNewChar <> "." Then sWd = Replace(sWd, _
         thisChar, myNewChar)
  End If
Next k
similarAllWords = sWd

' Catch words with only the final two letters the same
i = 0
If checkFinalLetters = True Then
  For Each myPara In finalList.Paragraphs
    gotOne = False
    myWord = Trim(myPara.Range.Words(1))
    myLen = Len(myWord)
    If myLen > 6 Then
      myTarget = "^p" & Left(myWord, myLen - 2) & "^$^$ "
      myCut = 2
    Else
      myTarget = "^p" & Left(myWord, myLen - 1) & "^$ "
      myCut = 1
    End If
    Set rng = finalList.Content
    rng.Start = myPara.Range.End - 3
    rng.Collapse wdCollapseStart
    With rng.Find
      .Replacement.ClearFormatting
      .ClearFormatting
      .Text = myTarget
      .Replacement.Text = ""
      .Forward = True
      .MatchCase = True
      .MatchWildcards = False
      .Wrap = wdFindStop
    End With
    rng.Find.Execute
    Do While rng.Find.Found
      gotOne = True
      rng.MoveStart 1
      rng.End = rng.Start + myLen - myCut
      rng.HighlightColorIndex = thisHighlight
      rng.Font.Bold = True
      rng.Find.Execute
    Loop
    If gotOne = True Then
      Set rng = myPara.Range.Words(1)
      rng.End = rng.Start + myLen - myCut
      rng.HighlightColorIndex = thisHighlight
      rng.Font.Bold = True
    End If
    i = i + 1
    If i Mod 100 = 1 Then
      DoEvents
      StatusBar = spcs & "Doing test (5) on " & myWord
      DoEvents
    End If
  Next myPara
End If

If doMissingLetter = True Then
' Start of test
  doneWords = ""
  doneSimilarWords = ""
  McList = ""

  For i = 1 To finalList.Paragraphs.Count - 1
    myWord = finalList.Paragraphs(i).Range.Words(1)
    n = AscW(myWord)
    thisChar = ChrW(n)
    myNewChar = "."
  ' Changes the capital letter, if a vowel
    If n > 191 And n < 221 Then
      myNewChar = Mid(convCharsUC, n - 191, 1)
      If myNewChar <> "." Then myWord = Replace(myWord, _
           thisChar, myNewChar)
    End If

    If i Mod 50 = 1 Then
      DoEvents
      StatusBar = spcs & "Other tests (4) on " & myWord
      DoEvents
    End If
    testWords = Replace(allWords, myWord, "")
    captestLetters = Left(myWord, 1)

  ' Check if word reappears with one letter missing (1)
    For k = 2 To Len(myWord) - 1
      testWord = " " & Left(myWord, k - 1) & Mid(myWord, k + 1)
      wordPos = InStr(allWords, testWord)
      If wordPos > 0 Then
        lastLetter = Mid(myWord, Len(myWord) - 1, 1)
      ' but not "s" at the end, unless it's a spelling error
        If lastLetter = "s" Then
          ignoreIt = (Application.CheckSpelling(myWord, _
          MainDictionary:=myLanguage) = True)
        Else
          ignoreIt = False
        End If
        If ignoreIt = False And ignorePlurals = True Then
          colcode = (colcode + 1) Mod maxCol
          thisCol = myCol(colcode + 1)

          ' mark the pair
          leftBit = Left(allWords, InStr(allWords, testWord) _
               + Len(testWord) - 1)
          j = Len(leftBit) - Len(Replace(leftBit, " ", ""))
          Set rng = finalList.Paragraphs(i).Range
          rng.HighlightColorIndex = thisCol
          rng.Font.Bold = True
          rng.Font.Color = wdColorBlue
          Set rng = finalList.Paragraphs(j).Range
          rng.HighlightColorIndex = thisCol
          rng.Font.Bold = True
          rng.Font.Color = wdColorBlue
        End If
      End If
    Next k

    If Left(myWord, 2) = "Mc" Or Left(myWord, 3) = "Mac" Or _
         Left(myWord, 3) = "Mag" Then
      McList = McList & ActiveDocument.Paragraphs(i).Range
    End If
  Next i
End If

If doSimilarLetters = True Then
  doneWords = ""
  doneSimilarWords = ""

  For i = 1 To finalList.Paragraphs.Count - 1
    myWord = finalList.Paragraphs(i).Range.Words(1)
    n = AscW(myWord)
    thisChar = ChrW(n)
    myNewChar = "."
   ' Changes the capital letter, if a vowel
    If n > 191 And n < 221 Then
      myNewChar = Mid(convCharsUC, n - 191, 1)
      If myNewChar <> "." Then myWord = Replace(myWord, _
           thisChar, myNewChar)
    End If
    If i Mod 50 = 1 Then
      DoEvents
      StatusBar = spcs & "Other tests (3) on " & myWord
      DoEvents
    End If
    testWords = Replace(allWords, myWord, "")
    captestLetters = Left(myWord, 1)

' check similar spellings: Perutz/Peruts or Chebyshev/Chevychev
    similarWord = " " & LCase(myWord)
    sChars = similarChars
    Do
      commaPos = InStr(sChars, ",")
      charWas = Left(sChars, commaPos - 1)
      sChars = Mid(sChars, commaPos + 1)
      semicolonPos = InStr(sChars, ";")
      charNew = Left(sChars, semicolonPos - 1)
      sChars = Mid(sChars, semicolonPos + 1)
      similarWord = Replace(similarWord, charWas, charNew)
    Loop Until Len(sChars) < 2
    ' Changes all the accented characters to non-accented
    For k = 1 To Len(myWord) - 1
      thisChar = Mid(myWord, k, 1)
      n = AscW(thisChar)
      If n > 191 And n < 256 Then
        myNewChar = Mid(convCharsUC, n - 191, 1)
        If myNewChar <> "." Then myWord = Replace(myWord, _
             thisChar, myNewChar)
      End If
    Next k
    similarAllWords = Mid(similarAllWords, Len(similarWord))
    theseWords = similarAllWords
    If InStr(doneSimilarWords, similarWord) = 0 And _
          InStr(theseWords, similarWord) > 0 Then
      colcode = (colcode + 1) Mod maxCol
      thisCol = myCol(colcode + 1)
      Set rng = finalList.Paragraphs(i).Range
      rng.HighlightColorIndex = thisCol
      rng.Font.Underline = True
      doneSimilarWords = doneSimilarWords & similarWord
      ' search through all the following words
      theseWords = similarAllWords
      For j = 1 To numWords - i
        spPos = InStr(Trim(theseWords) & " ", " ")
        If Left(theseWords, spPos + 1) = similarWord Then
          Set rng = finalList.Paragraphs(i + j).Range
          rng.HighlightColorIndex = thisCol
          rng.Font.Underline = True
        End If
        theseWords = Mid(theseWords, spPos + 1)
        capThisLetter = Mid(theseWords, 2, 1)
        If capThisLetter <> LCase(captestLetters) Then Exit For
      Next j
    End If
  Next i
End If

If switchTest = True Then
  doneWords = ""
  doneSimilarWords = ""
  McList = ""
  For i = 1 To finalList.Paragraphs.Count - 1
    myWord = finalList.Paragraphs(i).Range.Words(1)
    n = AscW(myWord)
    thisChar = ChrW(n)
    myNewChar = "."
   ' Changes the capital letter, if a vowel
    If n > 191 And n < 221 Then
      myNewChar = Mid(convCharsUC, n - 191, 1)
      If myNewChar <> "." Then myWord = Replace(myWord, _
           thisChar, myNewChar)
    End If
    If i Mod 50 = 1 Then
      DoEvents
      StatusBar = spcs & "Other tests (2) on " & myWord
      DoEvents
    End If
    testWords = Replace(allWords, myWord, "")
    captestLetters = Left(myWord, 1)

' check for switched chars
    wordLen = Len(myWord) - 1
    For k = 1 To Len(myWord) - 3
      otherWord = Left(myWord, k) & Mid(myWord, k + 2, 1) & _
            Mid(myWord, k + 1, 1) & Mid(myWord, k + 3)
      wordPos = InStr(testWords, otherWord)
      If wordPos > 0 Then
      ' Find the position of the matching word
        matchWord = Mid(testWords, wordPos, Len(myWord))
        leftBit = Left(allWords, InStr(allWords, matchWord) + 1)
        j = Len(leftBit) - Len(Replace(leftBit, " ", "")) + 1
        finalList.Paragraphs(i).Range.Font.DoubleStrikeThrough _
             = True
        finalList.Paragraphs(i).Range.HighlightColorIndex _
             = thisCol
        finalList.Paragraphs(j).Range.Font.DoubleStrikeThrough _
             = True
        finalList.Paragraphs(j).Range.HighlightColorIndex _
             = thisCol
      End If
    Next k
  Next i
End If

If doVowelTest = True Then
  doneWords = ""
  doneSimilarWords = ""
  McList = ""
  For i = 1 To finalList.Paragraphs.Count - 1
    myWord = finalList.Paragraphs(i).Range.Words(1)
    n = AscW(myWord)
    thisChar = ChrW(n)
    myNewChar = "."
   ' Changes the capital letter, if a vowel
    If n > 191 And n < 221 Then
      myNewChar = Mid(convCharsUC, n - 191, 1)
      If myNewChar <> "." Then myWord = Replace(myWord, _
           thisChar, myNewChar)
    End If
    If i Mod 50 = 1 Then
      DoEvents
      StatusBar = spcs & "Other tests (1) on " & myWord
      DoEvents
    End If
    testWords = Replace(allWords, myWord, "")
    captestLetters = Left(myWord, 1)

    ' check if there's a word with different vowels
    otherWord = " " & Replace(myWord, "a", "")
    otherWord = Replace(otherWord, "e", "")
    otherWord = Replace(otherWord, "i", "")
    otherWord = Replace(otherWord, "o", "")
    otherWord = Replace(otherWord, "u", "")
    otherWord = Replace(otherWord, "y", "")

    ' Delete all the accented characters
    For k = 3 To Len(otherWord) - 1
      thisChar = Mid(otherWord, k, 1)
      n = AscW(thisChar)
      If InStr("AEIOUY", thisChar) > 0 Then
        otherWord = Left(otherWord, k - 1) & "=" & Mid(otherWord, k + 1)
      Else
        If n > 191 And n < 221 Then
          myNewChar = Mid(convCharsUC, n - 191, 1)
          If myNewChar <> "." Then
            otherWord = Replace(otherWord, thisChar, "=")
          End If
        End If
      End If
    Next k
    otherWord = Replace(otherWord, "=", "")

' otherWord is now the word under test (vowel-less)
    otherWord = Replace(otherWord, ".", "")
    noVowelWords = Mid(noVowelWords, Len(otherWord))
    If Left(noVowelWords, 1) <> " " Then noVowelWords = _
         " " & noVowelWords
    theseWords = noVowelWords
    
    wordPos = InStr(noVowelWords, otherWord)
    If InStr(doneWords, otherWord) = 0 And wordPos > 0 Then
      colcode = (colcode + 1) Mod maxCol
      thisCol = myCol(colcode + 1)
      Set rng = finalList.Paragraphs(i).Range
      rng.HighlightColorIndex = thisCol
      rng.Font.Italic = True
      doneWords = doneWords & otherWord
      For j = 1 To numWords - i
        spPos = InStr(Trim(theseWords) & " ", " ")
        firstWord = Left(theseWords, spPos + 1)
        theseWords = Mid(theseWords, spPos + 1)
        If firstWord = otherWord Then
          Set rng = finalList.Paragraphs(i + j).Range
          rng.HighlightColorIndex = thisCol
          rng.Font.Italic = True
        End If
        capThisLetter = Mid(theseWords, 2, 1)
        If capThisLetter > "" And capThisLetter <> _
             captestLetters Then Exit For
      Next j
    End If
  Next i
End If

finishOff:
finalList.Activate
If Len(McList) > 0 Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText CR2 & McList
End If

Selection.HomeKey Unit:=wdStory
If finalList.Content.Words(1) = "Aaaaa " Then _
     finalList.Content.Paragraphs(1).Range.Delete
Selection.TypeText title1 & CR
Selection.Collapse wdCollapseStart
Do
  Selection.Expand wdParagraph
  If Len(Selection) < 3 Or LCase(Selection) = _
       UCase(Selection) Then Selection.Delete
Loop Until LCase(Selection) <> UCase(Selection)
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Style = finalList.Styles(wdStyleHeading1)

' Restore apostrophes
Set rng = finalList.Range
With rng.Find
  .Text = "qqq"
  .MatchCase = False
  .Replacement.Text = "'"
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

' Find first highlight
Set rng = finalList.Content
With rng.Find
  .Text = "Zzzzz"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = False
  .Execute Replace:=wdReplaceOne
End With

firstDoc.Close SaveChanges:=False
finalList.Activate
' Remove highlighting from second half of words
' that are only case changes of one another
totParas = finalList.Paragraphs.Count
For i = 1 To totParas - 1
  a = Trim(finalList.Paragraphs(i).Range.Words(1))
  b = Trim(finalList.Paragraphs(i + 1).Range.Words(1))
  a = Mid(a, 2)
  b = Mid(b, 2)
  If LCase(a) = LCase(b) And Len(a) > 2 Then
    If (UCase(a) = a And LCase(b) = b) Or (UCase(b) = b And _
         LCase(a) = a) Then
      finalList.Paragraphs(i).Range.Words(1).HighlightColorIndex = 0
      finalList.Paragraphs(i + 1).Range.Words(1).HighlightColorIndex _
           = 0
    End If
  End If
  If i Mod 50 = 0 Then
    DoEvents
    StatusBar = spcs & "Final checks: " & totParas - i
    DoEvents
  End If
Next i

myOnames = ""
Set rng = finalList.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^13O[!a-z]"
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchSoundsLike = False
  .MatchWildcards = True
  .Execute
End With

Do While rng.Find.Found = True
  rng.Collapse wdCollapseEnd
  rng.Expand wdWord
  wd = Mid(rng.Text, 3)
  rng.Expand wdParagraph
  pa = rng.Text
  Set rng2 = finalList.Content
  With rng2.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13" & wd
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = True
    .Execute
  End With
  If rng2.Find.Found Then
    rng2.Collapse wdCollapseEnd
    rng2.Expand wdParagraph
    pa2 = rng2.Text
    myOnames = myOnames & pa2 & pa & vbCr
  End If
  rng.Collapse wdCollapseEnd
  rng.End = rng.End - 2
  rng.Find.Execute
Loop
If myOnames > "" Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText "Possible O'<something> errors" & vbCr
  Selection.MoveUp , 1
  Selection.Style = finalList.Styles(wdStyleHeading1)
  Selection.EndKey Unit:=wdStory
  Selection.TypeText myOnames
  Selection.HomeKey Unit:=wdStory
End If

Set rng = finalList.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myDummy
  .Wrap = wdFindContinue
  .Replacement.Text = " "
  .Forward = True
  .MatchCase = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^$zzz^$" & leadDots & "1" & vbCr
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .Forward = True
  .MatchCase = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With

' Clear clipboard
Set rng = finalList.Content
rng.End = 2
rng.Copy

StatusBar = "Creating queries list"
Set rng = finalList.Content

For Each pa In finalList.Paragraphs
  pa.Range.Words(1).HighlightColorIndex = wdNoHighlight
Next pa
finalList.Paragraphs(1).Range.HighlightColorIndex = wdNoHighlight
Selection.HomeKey Unit:=wdStory
Set queriesDoc = Documents.Add
Selection.FormattedText = rng.FormattedText

queriesDoc.Paragraphs(1).Range.Delete
Set rng = queriesDoc.Content
rng.Font.StrikeThrough = True
For Each myPara In queriesDoc.Paragraphs
  Set ch = myPara.Range.Characters(1)
  chCol = ch.HighlightColorIndex
  If chCol > 0 Then
    myPara.Range.Font.StrikeThrough = False
  End If
  myLen = Len(myPara.Range.Text)
  If myLen > 4 Then
    If chCol > 0 Then
      myPara.Range.Font.StrikeThrough = False
    End If
    Set che = myPara.Range.Characters(myLen - 2)
    If che.HighlightColorIndex > 0 Then
      myPara.Range.Font.StrikeThrough = False
    End If
    If myPara.Range.Characters(1).Bold = True Then
      myPara.Range.Font.StrikeThrough = False
    End If
  End If
Next myPara
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.StrikeThrough = True
  .Wrap = wdFindContinue
  .Replacement.Text = "^p"
  .Forward = True
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
End With
Set rng = queriesDoc.Content
rng.Font.StrikeThrough = False
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[^13]{3,}"
  .Wrap = wdFindContinue
  .Replacement.Text = "^p^p"
  .Forward = True
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With

Set rng = queriesDoc.Content
rng.Font.Bold = False
rng.Font.Italic = False
rng.Font.DoubleStrikeThrough = False
rng.Font.Underline = False
rng.Font.Color = wdColorBlack
Selection.HomeKey Unit:=wdStory
Selection.TypeText title2 & CR
Set rng = queriesDoc.Content.Paragraphs(2).Range
If rng.Text = vbCr Then rng.Delete

StatusBar = " "
Options.DefaultHighlightColorIndex = oldColour

lighterColour = wdGray50
Set rng = queriesDoc.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = " [0-9]{1,}"
  .Replacement.Font.Italic = False
  .Replacement.Text = ""
  .Replacement.Highlight = False
  .Replacement.Font.Color = wdColorAutomatic
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[a-zA-Z]{1,} "
  .Replacement.Text = ""
  .Replacement.Font.Italic = False
  .Replacement.Font.Color = wdColorAutomatic
  .Execute Replace:=wdReplaceAll
  DoEvents

  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.Color = wdColorBlue
  .Replacement.Text = ""
  .Replacement.Font.Underline = True
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
Set rng = queriesDoc.Content.Paragraphs(1).Range
rng.Style = queriesDoc.Styles(wdStyleHeading1)
Beep
If keepWholeList = False Then _
     finalList.Close SaveChanges:=False

Application.ScreenUpdating = True
If doingSeveralMacros = False Then
  myTime = (Int(10 * (Timer - timeStart) / 60) / 10)
  Beep
  If myTime > 0 Then MsgBox myTime & "  minutes"
End If
If InStr(FUT.Name, "zzTestFile") > 0 Then
  FUT.Activate
Else
  queriesDoc.Activate
End If
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub


Sub QuickSort(arr As Variant, ByVal low As Long, ByVal high As Long)
' Paul Beverley - Version 21.12.24
' Sorts an array of text at high speed

Dim i As Long
Dim j As Long
Dim pivot As String
Dim temp As String

i = low
j = high
pivot = arr((low + high) \ 2)

Do While i <= j
  Do While arr(i) < pivot
      i = i + 1
  Loop
  Do While arr(j) > pivot
      j = j - 1
  Loop
  If i <= j Then
    temp = arr(i)
    arr(i) = arr(j)
    arr(j) = temp
    i = i + 1
    j = j - 1
  End If
Loop

If low < j Then QuickSort arr, low, j
If i < high Then QuickSort arr, i, high
End Sub