Sub UKUScount() ' Paul Beverley - Version 29.10.24 ' Counts relative spellings between UK and US English minLengthSpell = 5 doCount = True timeStart = Timer UKcount = 0 UScount = 0 CR = vbCr UKwords = CR USwords = CR Selection.HomeKey Unit:=wdStory i = ActiveDocument.Words.Count iStart = i StatusBar = "Spellchecking. To go: 100%" On Error GoTo ReportIt Application.ScreenUpdating = False 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 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 DoEvents End If Next wd Application.ScreenUpdating = True endTime = Timer MsgBox "Total words" & 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") 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 Selection.TypeText Text:=CR & "US: " & Trim(Str(lenOne - lenTwo)) & CR Selection.HomeKey Unit:=wdStory Selection.TypeText Text:="Distinct words" & CR & CR & "UK: " & _ Trim(Str(lenTwo - lenThree)) & CR Exit Sub ReportIt: Application.ScreenUpdating = True On Error GoTo 0 Resume End Sub