Sub UKUScount()
' Paul Beverley - Version 18.09.25
' Counts relative spellings between UK and US English

minLengthSpell = 5
doCount = True

myWarn = "        Press # to stop"
UKcount = 0
UScount = 0
CR = vbCr
CR2 = CR & CR
UKwords = CR
USwords = CR
Selection.HomeKey Unit:=wdStory
myWds = ActiveDocument.Words.Count
myTot = ActiveDocument.Characters.Count
iStart = myWds
StatusBar = "Spellchecking. To go:   100%"
myTime = Timer
Do
  DoEvents
Loop Until Timer > myTime + 0.5
timeStart = Timer
For Each wd In ActiveDocument.Words
  myWrd = Replace(Trim(wd), ChrW(8217), "")
  If Len(myWrd) >= minLengthSpell And wd.Font.StrikeThrough = False Then
    UKok = Application.CheckSpelling(myWrd, _
         MainDictionary:=Languages(wdEnglishUK).NameLocal)
    USok = Application.CheckSpelling(myWrd, _
         MainDictionary:=Languages(wdEnglishUS).NameLocal)
    If UKok <> USok Then
      If UKok Then
        UKcount = UKcount + 1
        If InStr(UKwords, "!" & LCase(myWrd) & CR) = 0 Then _
             UKwords = UKwords & "!" & LCase(myWrd) & CR
      Else
        UScount = UScount + 1
        If InStr(USwords, "$" & LCase(myWrd) & CR) = 0 Then _
             USwords = USwords & "$" & LCase(myWrd) & CR
      End If
      wd.Select
      myEnd = Selection.End
      StatusBar = "Spellchecking. To go:   " & Trim(Str(Int((myWds / iStart) _
           * 100))) & "%                           UK:  " & UKcount & _
           "      US:  " & UScount
      Debug.Print "Spellchecking. To go:   " & Trim(Str(Int((myWds / iStart) _
      * 100))) & "%                           UK:  " & UKcount & _
      "      US:  " & UScount
    End If
  End If
  myWds = myWds - 1
  If Selection.End <> myEnd Then
    WordBasic.EditUndo
    Exit For
  End If
  If myWds Mod 400 = 0 Then
    StatusBar = "Spellchecking. To go:   " & _
         Trim(Str(Int((myWds / iStart) * 100))) & _
         "%                           UK:  " & _
         UKcount & "      US:  " & UScount & myWarn
    DoEvents
  End If
Next wd
endTime = Timer
MsgBox "Total words counted" & CR & CR & "UK: " & UKcount _
     & CR & CR & "US: " & UScount
totTime = endTime - timeStart
If doCount = True Then
   If totTime > 60 Then MsgBox ((Int(10 * totTime / 60) / 10) & _
     "  minutes")
'   If totTime > 1 Then MsgBox (totTime & "  seconds")
End If
Selection.HomeKey Unit:=wdStory
Beep
myResponse = MsgBox("List the different words found?", _
     vbQuestion + vbYesNo, "UKUScount")
If myResponse <> vbYes Then Exit Sub

Documents.Add
Selection.TypeText Text:=UKwords & CR & USwords
Set rng = ActiveDocument.Content
rng.Sort
rng.InsertAfter Text:=CR
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[^13]{1,}\!"
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = ""
  .MatchWildcards = True
  .Execute Replace:=wdReplaceOne
  DoEvents
  .Text = "$"
  .Replacement.Text = "^p^p"
  .MatchWildcards = False
  .Execute Replace:=wdReplaceOne
  Set rng2 = ActiveDocument.Content
  lenOne = Len(rng2)
  .Text = "$"
  .Replacement.Text = ""
  .Execute Replace:=wdReplaceAll
  lenTwo = Len(rng2)
  .Text = "!"
  .Execute Replace:=wdReplaceAll
  lenThree = Len(rng2)
End With

ActiveDocument.Content.Text = Replace(ActiveDocument.Content.Text, 
     CR2 & CR, CR2 & CR & "US: " & Trim(Str(lenOne - lenTwo + 1)) & CR)
Selection.HomeKey Unit:=wdStory
Selection.TypeText Text:="Distinct words" & CR & CR & "UK: " & _
     Trim(Str(lenTwo - lenThree + 1)) & CR
End Sub