...Unit:=wdStory
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Font.Position > 0 Then Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
If Selection.End = ActiveDocument.Range.End - 1 Then Exit Do
Loop
End Sub