Sub OpenQuotesToApostrophes()
' Paul Beverley - Version 08.09.25
' Finds initial abbreviations and changes open quotes to apostrophes

myWords = "em, phone, twas, ello"

myCount = 0
myWords = Replace("," & myWords & ",", " ", "")
myWords = Replace(myWords, ",,", ",")
aWord = Split(myWords, ",")

For i = 1 To UBound(aWord) - 1
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ChrW(8216) & aWord(i) & ">"
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = True
    .MatchWholeWord = False
    .Execute
  End With
  
  Do While rng.Find.Found = True
    myCount = myCount + 1
    If myCount Mod 20 = 0 Then rng.Select
    rng.Characters(1) = ChrW(8217)
    rng.Collapse wdCollapseEnd
    rng.Find.Execute
    DoEvents
  Loop
Next i
Beep
MsgBox "Changed: " & myCount
End Sub