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

minLengthSpell = 5
countIt = True

timeStart = Timer
UKcount = 0
UScount = 0
i = ActiveDocument.Words.Count
iStart = i
StatusBar = "Spellchecking. To go:   100%"
On Error GoTo ReportIt
Application.ScreenUpdating = False
For Each wd In ActiveDocument.Words
  DoEvents
  If Len(wd) >= minLengthSpell And wd.Font.StrikeThrough = False Then
    UKok = Application.CheckSpelling(wd, _
         MainDictionary:=Languages(wdEnglishUK).NameLocal)
    USok = Application.CheckSpelling(wd, _
         MainDictionary:=Languages(wdEnglishUS).NameLocal)
    If UKok <> USok Then
      If UKok Then
        UKcount = UKcount + 1
      Else
        UScount = UScount + 1
      End If
      wd.Select
      StatusBar = "Spellchecking. To go:   " & Trim(Str(Int((i / iStart) _
           * 100))) & "%                           UK:  " & UKcount & _
           "      US:  " & UScount
      Debug.Print "Spellchecking. To go:   " & Trim(Str(Int((i / iStart) _
      * 100))) & "%                           UK:  " & UKcount & _
      "      US:  " & UScount
    End If
  End If
  i = i - 1
  If i Mod 1000 = 0 Then StatusBar = "Spellchecking. To go:   " & _
       Trim(Str(Int((i / iStart) * 100))) & _
       "%                           UK:  " & _
       UKcount & "      US:  " & UScount
Next wd
Application.ScreenUpdating = True
endTime = Timer
MsgBox "UK: " & UKcount & vbCr & vbCr & "US: " & UScount
totTime = endTime - timeStart
If countIt = True Then
   If totTime > 60 Then MsgBox ((Int(10 * totTime / 60) / 10) & _
     "  minutes")
End If
Selection.HomeKey Unit:=wdStory
Beep
Exit Sub

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