Sub Demo()
  Dim rng As Range
  Application.ScreenUpdating = False
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Font.Italic = True
      .Text = "*>"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      .Collapse wdCollapseEnd
      .MoveEnd Unit:=wdCharacter, Count:=1
      Debug.Print .Characters(1)
      Select Case .Characters(1)
        Case ".", ",", ":", ";", "?", "!"
          .Characters(1).Font.Italic = True
      End Select
      .MoveStart wdCharacter, 1
      .Find.Execute
    Loop
  End With
  Application.ScreenUpdating = True
End Sub