Consulting

Results 1 to 5 of 5

Thread: cyrillic transliterator macro for Word

  1. #1
    VBAX Newbie
    Joined
    Oct 2021
    Posts
    3
    Location

    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

    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

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,027
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Newbie
    Joined
    Oct 2021
    Posts
    3
    Location
    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

  4. #4
    Change
    .Wrap = wdFindContinue
    to
    .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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Oct 2021
    Posts
    3
    Location
    Thanks Graham Mayor. Now it works as I hoped. I will mark the thread solved.

    Russ

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •