cyrillic transliterator macro for Word

[Paul_Hossler]

Sort of brute force. Maybe someone will have a fancier idea

Capture.JPG

Option Explicit


'PURPOSE: Find & Transliterate Cyrillic Characters
Sub Selection_Transliterate_Cyrillic()
    
    Dim aryFind As Variant
    Dim aryReplace As Variant
    Dim i As Long




    Application.ScreenUpdating = False


    aryFind = Array(ChrW(&H410), ChrW(&H411), ChrW(&H412), ChrW(&H413), ChrW(&H414), ChrW(&H415), ChrW(&H401), ChrW(&H416), ChrW(&H417), ChrW(&H418), ChrW(&H419), ChrW(&H41A), ChrW(&H41B), ChrW(&H41C), ChrW(&H41D), ChrW(&H41E), ChrW(&H41F), ChrW(&H420), ChrW(&H421), ChrW(&H422), ChrW(&H423), ChrW(&H424), ChrW(&H425), ChrW(&H426), ChrW(&H427), ChrW(&H428), ChrW(&H429), ChrW(&H42A), ChrW(&H42B), ChrW(&H42C), ChrW(&H42D), ChrW(&H42E), ChrW(&H42F), ChrW(&H406), ChrW(&H472), ChrW(&H462), ChrW(&H474), ChrW(&H430), ChrW(&H431), ChrW(&H432), ChrW(&H433), ChrW(&H434), ChrW(&H435), ChrW(&H451), ChrW(&H436), ChrW(&H437), ChrW(&H438), ChrW(&H439), ChrW(&H43A), ChrW(&H43B), ChrW(&H43C), ChrW(&H43D), ChrW(&H43E), ChrW(&H43F), ChrW(&H440), ChrW(&H441), ChrW(&H442), ChrW(&H443), ChrW(&H444), ChrW(&H445), ChrW(&H446), ChrW(&H447), ChrW(&H448), ChrW(&H449), ChrW(&H44A), ChrW(&H44B), ChrW(&H44C), ChrW(&H44D), ChrW(&H44E), ChrW(&H44F), ChrW(&H456), ChrW(&H473), ChrW(&H463), ChrW(&H475))
    aryReplace = Array("A", "B", "V", "G", "D", "E", "Yo", "Zh", "Z", "I", "Y", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Shch", "", "Y", "", "E", "Yu", "Ya", "I", "F", "E", "I", "a", "b", "v", "g", "d", "e", "yo", "zh", "z", "i", "y", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", "shch", "", "y", "", "e", "yu", "ya", "i", "f", "e", "i")


    For i = LBound(aryFind) To UBound(aryFind)
        Call pvtUnicodeChar(aryFind(i), aryReplace(i))
    Next i


    Application.ScreenUpdating = True
End Sub




Private Sub pvtUnicodeChar(ByVal F As String, ByVal R As String)
    With Selection.Find
        .ClearFormatting
        
        .Text = F
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        
        .Replacement.ClearFormatting
        .Replacement.Text = R
        
        .Execute Replace:=wdReplaceAll
    End With


End Sub