Sub RemoveAccents()
Application.ScreenUpdating = False
Dim i As Long, ArrFnd, ArrRep
ArrFnd = Array("À", "Á", "Â", "Ã", "Ä", "Å", "Æ", "Ç", "È", "É", "Ê", "Ë", _
"Ì", "Í", "Î", "Ï", "Ð", "Ñ", "Ò", "Ó", "Ô", "Õ", "Ö", "Ø", "Ù", "Ú", "Û", _
"Ü", "Ý", "à", "á", "â", "ã", "ä", "å", "æ", "ç", "è", "é", "ê", "ë", "ì", _
"í", "î", "ï", "ð", "ñ", "ò", "ó", "ô", "õ", "ö", "ø", "ù", "ú", "û", "ü", "ý", "ÿ")
ArrRep = Array("A", "A", "A", "A", "A", "A", "AE", "C", "E", "E", "E", "E", _
"I", "I", "I", "I", "D", "N", "O", "O", "O", "O", "O", "O", "U", "U", "U", _
"U", "Y", "a", "a", "a", "a", "a", "a", "ae", "c", "e", "e", "e", "e", "i", _
"i", "i", "i", "o", "n", "o", "o", "o", "o", "o", "o", "u", "u", "u", "u", "y", "y")
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .MatchCase = True
  For i = 0 To UBound(ArrFnd)
    .Execute FindText:=ArrFnd(i), ReplaceWith:=ArrRep(i), Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub