Sub OdstraňovačDiakritikyVše()
Odpoved = MsgBox("Opravdu chcete odstranit diakritiku z celého dokumentu?", 3 + vbDefaultButton2 + vbExclamation)
If Odpoved = vbCancel Then Exit Sub
If Odpoved = vbNo Then Exit Sub
If Odpoved = vbYes Then
    Call OdstraňovačDiakritiky
End If
End Sub
Function OdstraňovačDiakritiky()
knahrazeni = Array("á|a", "ä|ae", "ě|e", "é|e", "ë|e", "í|i", "ľ|l", "ó|o", "ö|oe", "ú|u", "ů|u", "ü|ue", "š|s", "č|c", "ř|r", "ž|z", "ý|y", "ď|d", "ť|t", "ň|n", ChrW(239) & "|i", ChrW(255) & "|y", ChrW(224) & "|a", ChrW(232) & "|e", ChrW(236) & "|i", ChrW(242) & "|o", ChrW(249) & "|u", "â|a", ChrW(234) & "|e", "î|i", "ô|o", ChrW(251) & "|u", ChrW(227) & "|a", ChrW(241) & "|n", ChrW(245) & "|o", "ç|c", ChrW(339) & "|oe")
For i = 0 To UBound(knahrazeni)
    polozka = knahrazeni(i)
    oddelovac = InStr(polozka, "|")
    co = Left(polozka, oddelovac - 1)
    zaco = Mid(polozka, oddelovac + 1)
    Call Nahradit(co, zaco)
Next
End Function
Function Nahradit(co, zaco, Optional kolikrat, Optional zhotovitSoupis = False)
Do
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = co
        .Replacement.Text = zaco
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        pojednom = False
        If IsMissing(kolikrat) And zhotovitSoupis = False Then 'Neměnit na IsEmpty!
            .Execute Replace:=wdReplaceAll
            Exit Do
        Else
            .Execute Replace:=wdReplaceOne
            provedeno = provedeno + 1
            If zhotovitSoupis = True Then Soupis = Soupis & Selection.Text & vbCrLf
        End If
    End With
Loop While provedeno < kolikrat 'Or pojednom = True
Selection.MoveRight wdCharacter
If Len(Soupis) <> 0 Then VypisDoTXT Soupis
End Function
Function VypisDoTXT(co)
Set fso = CreateObject("Scripting.FileSystemObject")
tempdir = fso.GetSpecialFolder(2)
tempname = fso.GetTempName
tempfile = fso.BuildPath(tempdir, tempname)
Set txt = fso.CreateTextFile(tempfile)
txt.write co
Set ws = CreateObject("Wscript.Shell")
ws.Run "notepad " & tempfile
Set txt = Nothing
Start = Timer
Do
    DoEvents
Loop While Start + 3 > Timer
Kill tempfile
End Function