cyrillic transliterator macro for Word

[ohioruss]

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


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

[Paul_Hossler]

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

29042



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

[ohioruss]

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

[gmayor]

Change

.Wrap = wdFindContinueto
.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.

[ohioruss]

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

Russ