Try:
Code:
Sub Demo1()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[aeiouyæ" & ChrW(593) & ChrW(596) & ChrW(601) & ChrW(604) & ChrW(618) & ChrW(650) & ChrW(652) & "]{1,}" _
& ChrW(9700) & _
"[!^32-^62\?\@aeiouyæ" & ChrW(593) & ChrW(596) & ChrW(601) & ChrW(604) & ChrW(618) & ChrW(650) & ChrW(652) & "]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
.Borders.Enable = True
.InsertBefore "|"
Set Rng = .Duplicate
With Rng
.Collapse wdCollapseStart
.Text = ChrW(2588)
With .Font
.Size = 8
.Color = 49407
.Superscript = True
End With
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub