Sub SpellingErrorLister()
' Paul Beverley - Version 02.03.22
' Generates an alphabetic list all the spelling 'errors'

spellingListName = "SpellingErrors"

myFind = "´a,´e,¨a,¨e,¨o,¨u,ˆo,"
myReplace = "á,é,ä,ë,ö,ü,ô,"

CR = vbCr
CR2 = CR & CR

Set FUT = ActiveDocument
doingSeveralMacros = (InStr(FUT.Name, "zzTestFile") > 0)

' List possible spelling errors
thisLanguage = Selection.LanguageID
Select Case thisLanguage
  Case wdEnglishUK: myLang = "UK spelling"
  Case wdEnglishUS: myLang = "US spelling"
  Case wdEnglishCanadian: myLang = "Canadian spelling"
  Case Else: myLang = "unknown language"
End Select
myLang = "Using " & myLang & " dictionary. OK?"
If doingSeveralMacros = False Then
  myResponse = MsgBox(myLang, vbQuestion + vbYesNoCancel, _
       "Spelling Error Lister")
  If myResponse <> vbYes Then Exit Sub
End If
timeStart = Timer

langName = Languages(thisLanguage).NameLocal
Set rngOK = ActiveDocument.Content
OKstart = InStr(rngOK.Text, "OKwords")
If OKstart > 0 Then
  rngOK.Start = OKstart + 6
  OKwords = rngOK.Text
Else
  OKwords = ""
End If

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^2"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  
  .Text = "([!a-zA-Z])['" & ChrW(8216) & "]"
  .Replacement.Text = "\1"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With

' Change ligature characters into character pairs
myFind = myFind & "," & ChrW(-1280) & "," & ChrW(-1279) & _
     "," & ChrW(-1278) & "," & ChrW(-1277) & "," _
     & ChrW(-1276)
myReplace = myReplace & ",ff,fi,fl,ffi,ffl"
fnd = Split(myFind, ",")
rpl = Split(myReplace, ",")
For i = 0 To UBound(fnd)
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = fnd(i)
    .Wrap = wdFindContinue
    .Replacement.Text = rpl(i)
    .MatchCase = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
  If ActiveDocument.Footnotes.count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = fnd(i)
      .Wrap = wdFindContinue
      .Replacement.Text = rpl(i)
      .MatchCase = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
  End If
  If ActiveDocument.Endnotes.count > 0 Then
    Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = fnd(i)
      .Wrap = wdFindContinue
      .Replacement.Text = rpl(i)
      .MatchCase = False
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
  End If
Next i

' Create spelling error list
erList1 = CR
erList2 = CR
numFootnotes = ActiveDocument.Footnotes.count
numEndnotes = ActiveDocument.Endnotes.count

myEnd = ActiveDocument.Content.End
For i = 1 To 3
  If myResponse = vbNo Then i = 3
  If i = 1 And numFootnotes = 0 Then i = 2
  If i = 1 Then Set rng = ActiveDocument.StoryRanges(wdFootnotesStory)
  If i = 2 And numEndnotes = 0 Then i = 3
  If i = 2 Then Set rng = ActiveDocument.StoryRanges(wdEndnotesStory)
  If i = 3 Then Set rng = ActiveDocument.Content
  For Each wd In rng.Words
    If Len(Trim(wd)) > 2 And LCase(wd) <> UCase(wd) And _
         wd.Font.StrikeThrough = False And wd <> "OKwords" Then
         padWd = " " & Trim(wd) & " "
      OKword = (InStr(OKwords, CR & Trim(wd) & CR) > 0)
      DoEvents
      If Application.CheckSpelling(wd, MainDictionary:=langName) = _
           False And OKword = False Then
        pCent = Int((myEnd - wd.End) / myEnd * 100)

        ' Report progress
        If i = 1 Then myPrompt = "Checking footnote text."
        If i = 2 Then myPrompt = "Checking endnote text."
        If i = 3 Then myPrompt = "Checking main text."
        StatusBar = "Generating errors list. " & myPrompt & _
             " To go:  " & Trim(Str(pCent)) & "%"
        Debug.Print "Generating errors list. " & myPrompt & _
             " To go:  " & Trim(Str(pCent)) & "%"
        erWord = Trim(wd)
        lastChar = Right(erWord, 1)
        If lastChar = "'" Or lastChar = ChrW(8217) Then
          erWord = Left(erWord, Len(erWord) - 1)
        End If
        myCap = Left(erWord, 1)
        If UCase(myCap) = myCap Then
          If InStr(erList1, CR & erWord & CR) = 0 Then erList1 = erList1 _
               & erWord & CR
        Else
          If InStr(erList2, CR & erWord & CR) = 0 Then erList2 = erList2 _
               & erWord & CR
        End If
      End If
    End If
  Next wd
Next i
mainFileName = ActiveDocument.Name
Documents.Add
Selection.TypeText erList2
Selection.WholeStory
Selection.Sort SortOrder:=wdSortOrderAscending, _
     SortFieldType:=wdSortFieldAlphanumeric

If erList1 <> CR Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText CR2
  listStart = Selection.Start
  Selection.TypeText erList1
  Selection.Start = listStart
  Selection.Sort SortOrder:=wdSortOrderAscending, _
       SortFieldType:=wdSortFieldAlphanumeric
End If

Selection.WholeStory
Selection.LanguageID = thisLanguage
Selection.Style = wdStyleNormal

Selection.Collapse wdCollapseStart

If numFootnotes > 0 Then
  Selection.TypeText CR & "| footnotes = yes" & CR
End If
If numEndnotes > 0 Then
  Selection.TypeText CR & "| endnotes = yes" & CR
End If

StatusBar = ""
Selection.HomeKey Unit:=wdStory
Selection.TypeText spellingListName & vbCr
ActiveDocument.Paragraphs(1).Style = ActiveDocument.Styles(wdStyleHeading1)

If doingSeveralMacros = False Then
  totTime = Int(10 * (Timer - timeStart) / 60) / 10
  If totTime > 2 Then myResponse = MsgBox((totTime & "  minutes"), _
  vbOKOnly, "Spelling Error Lister")
  Beep
Else
  FUT.Activate
End If
End Sub