cyrillic transliterator macro for Word

Hello, I have a cyrillic transliteration macro for excel that I would like to adapt for Word 2013. In excel, the macro operates on any characters in selected cells. In word, I would like it to operate on selected text, but I don't know how to code that.

The excel macro code is shown below.

Thanks in advance.

Russ

Code:

---

Sub Selection_Transliterate_Cyrillic()
'PURPOSE: Find & Transliterate Cyrillic Characters


    Dim Rng As Range
    Dim FndList As Variant
    Dim rplcList As Variant
    Dim X As Long


    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual


FndList = 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))


rplcList = 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")




    With ActiveWorkbook.ActiveSheet
        Set Rng = Intersect(ActiveSheet.UsedRange, Selection)
            'Loop through each item in Array lists
            For X = LBound(FndList) To UBound(FndList)
                  Rng.Cells.Replace what:=FndList(X), replacement:=rplcList(X), _
          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True, _
          SearchFormat:=False, ReplaceFormat:=False
              Next X
       
    End With


    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
End Sub

---

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

Attachment 29042

Code:

---

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

---

Thanks Paul. I have one issue, though, and a question.
1. The macro ignores the selection and transliterates the entire document. Need to fix this.
2. Is clearformatting necessary in the private sub? I would like to preserve formatting.

Russ

Change

Code:

---

.Wrap = wdFindContinue

---

to

Code:

---

.Wrap = wdFindStop

---

The ClearFormatting command doesn't change the formatting of the document, but the formatting of the search e.g. if you searched previously for bold text, it clears that bold attribute from the search parameters.

Thanks Graham Mayor. Now it works as I hoped. I will mark the thread solved.

Russ