Sub Macro1()
  Dim aRng As Range, iType As Integer
  On Error GoTo EndSub    'footnotes story may not exist in all docs
  For iType = 1 To 2
    Set aRng = ActiveDocument.StoryRanges(iType)   'wdMainTextStory = 1, wdFootnotesStory = 2
    With aRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Font.Italic = True
      .Replacement.Style = ActiveDocument.Styles("Emphasis")
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchKashida = False
      .MatchDiacritics = False
      .MatchAlefHamza = False
      .MatchControl = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute Replace:=wdReplaceAll
    End With
  Next iType
EndSub:
End Sub