Транслит

Если Вам часто приходится переводить кириллицу в транслит (а попробуйте-ка сделать это для фамилии "Кржижановский", например), то эта функция - для Вас.

Откройте редактор Visual Basic (Alt+F11), вставьте через меню новый пустой программный модуль (Insert - Module) и скопируйте туда текст этой функции:

Function Translit(Txt As String) As String

    Dim Rus As Variant
    Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
    "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
    "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _
    "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
    "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я")

    Dim Eng As Variant
    Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _
    "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
    "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _
    "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _
    "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA")
    
    For I = 1 To Len(Txt)
        с = Mid(Txt, I, 1)
    
        flag = 0
        For J = 0 To 65
            If Rus(J) = с Then
                outchr = Eng(J)
                flag = 1
                Exit For
            End If
        Next J
        If flag Then outstr = outstr & outchr Else outstr = outstr & с
    Next I
    
    Translit = outstr
    
End Function

Теперь на любом листе этой книги Вы можете использовать эту функцию, вставив ее через Мастер Функций:

  • в Excel 2003 и старше - через меню Вставка - Функция (Insert - Function)
  • в Excel 2007 и новее - через вкладку Вставка - Функция (Insert - Function)

 из категории Определенные пользователем (User defined):

translit.gif

В этом макросе варианты замены русских букв английскими эквивалентами представлены согласно ГОСТ. Если для вашей задачи нужны другие версии (например, русская "я" должна выводиться как "ja", а не как "ya" и т.д.), то можно свободно подкорректировать это в теле макроса. Как легко догадаться, два первых массива Rus и Eng как раз и кодируют эти подстановки.

Для новых версий Excel 2007-2010 и т.д. не забудьте сохранить вашу книгу как файл с поддержкой макросов (Macro Enabled Workbook), т.е. в формате XLSM.

Ссылки по теме

 


22.09.2012 22:58:41
Ух ты, спасибо!:D
Бескаравайная Елена
04.10.2012 00:01:40
Чудесный макрос, давно искала :), но есть проблема: на чистом листе новой книги все работает отлично, а в нужном мне документе вместо значения встает сама функция:=Translit(B143).Видимо надо изменить свойства документа...но какие?
06.10.2012 17:43:33
Эту функцию надо вставлять в каждую книгу, где вы хотите использовать транслит.
Almir
04.10.2012 00:02:28
Огромноейшее спасибо за макрос, просто спасение на работе!
15.06.2013 19:46:28
Здравствуйте Уважаемый Николай и все обитатели этого прекрасного сайта. Обращаюсь к Вам как к Гуру в Екселе.
Подскажите пожалуйста как сделать две функции в екселе
1я функция, что бы в одном из столбцов всегда писались только ПРОПИСНЫЕ БУКВЫ.(через формулу "ПРОПИСН" это делать не удобно)
2я функция. что бы в одном из столбцов, печать осуществлялась только на русском языке, если даже в данный момент стоит другой язык.
надеюсь на Вашу помощь, как на последнюю инстанцию
С Уважением "Чайник в екселе" Юрий.
28.07.2013 10:21:23
Во-первых, с такими вопросами лучше на форум все-таки. Во-вторых, такое только макросами. В-третьих, насчет автоматического переключения языка в нужном столбце я сильно сомневаюсь :)
26.03.2014 12:48:27
Доброго времени суток Есть ли переводчик с украинского на русский !!!
16.11.2014 09:43:30
Это не переводчик, а транслитератор. Если нужно, то просто замените русские символы в коде на украинские и их аналоги на латинице.
31.03.2014 13:41:04
Добрый день. Подскажите пожалуйста, Этот модуль прекрасно работает, за что вам огромное СПАСИБО!))... только есть проблемка, у меня есть программа в которую можно вставить только МАКРОС пост обработки выгружаемого файла xls, т.е. вставляя этот модуль программа незнает что делать, Каким образом можно этот модуль переделать в простой макрос (типа Sub.....End Sub)??
16.11.2014 09:38:42
Будет примерно так:
Sub Translit
 
    Dim Rus As Variant
    Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
    "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
    "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _
    "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
    "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я")
 
    Dim Eng As Variant
    Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _
    "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
    "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _
    "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _
    "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA")

    For each Txt in Range("A1:A100") 
    For I = 1 To Len(Txt)
        с = Mid(Txt, I, 1)
     
        flag = 0
        For J = 0 To 65
            If Rus(J) = с Then
                outchr = Eng(J)
                flag = 1
                Exit For
            End If
        Next J
        If flag Then outstr = outstr & outchr Else outstr = outstr & с
    Next I
     
    Txt.Value = outstr
    Next Txt 
End Sub
 


Этот макрос будет перебирать ячейки в диапазоне А1:А100 и превращать их в транслит.
29.01.2015 06:37:18
Помогите, пожалуйста. Необходим обратный перевод с транслита на русский язык. что, кроме алфавита нужно поменять.
Вот, что я пробовала писать, не получилось.

Заранее огромнейшее спасибо.
06.04.2015 15:43:59
Хотел бы выразить благодарность за Ваш сайт и задать вопрос по данному макросу! Как можно исправить в макросе чтобы при сочетании букв "ый" макрос выдавал "iy", а при отдельном использовании букв было "ы"="y" и при "й" тоже "y". Т.е в слове "каждый" необходимо, чтобы было "kajdiy", а не "kajdyy"
04.08.2015 10:59:05
Сделал все как указано, но при вставке функции выдает ошибку Compile error: Sub or Function not defined.

Курсор с желтой подсветкой указывает на первую строчку скрипта. В чем может быть проблема?
05.08.2015 14:37:29
Добрый день!
Николай допустил небольшую опечатку.
Замените последнюю строку End Function на End Sub.
05.08.2015 14:56:08
Добрый день!
И еще тут строчки не хватает, которая будет "обнулять" накопление.
У меня в итоге вот что получилось:
Sub Translit()
 
    Dim Rus As Variant
    Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
    "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
    "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", _
    "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
    "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я";)
 
    Dim Eng As Variant
    Eng = Array("a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "j", _
    "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", _
    "sh", "sch", "''", "y", "'", "e", "yu", "ya", "A", "B", "V", "G", "D", _
    "E", "JO", "ZH", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", _
    "S", "T", "U", "F", "KH", "TS", "CH", "SH", "SCH", "''", "Y", "'", "E", "YU", "YA";)

    For Each Txt In Range("A1:A100";)
    For I = 1 To Len(Txt)
        с = Mid(Txt, I, 1)
        flag = 0
        For J = 0 To 65
            If Rus(J) = с Then
                outchr = Eng(J)
                flag = 1
                Exit For
            End If
        Next J
        If flag Then outstr = outstr & outchr Else outstr = outstr & с
    Next I
     
    Txt.Value = outstr
    outstr = ""
    Next Txt
End Sub
В Экселе 2013 года не могу найти в функциях категорию "Определенные пользователем", следовательно, не могу применить макрос. Помогите, пожалуйста, в поиске))
15.09.2015 14:23:12
Подскажите, как сделать, чтобы в место пробела вставлялось нижнее подчеркивание?
13.11.2015 09:12:23
Здравствуйте понадобилось сделать примерно тоже самое только для греческого текста, но как только копирую код с греческими буквами в VBA они пропадают.

что я делаю не правильно?
Function Translit(Txt As String) As String
 
    Dim Gr As Variant
    Gr = Array("α", "β", "γ", "δ", "ε", "ζ", "η", "θ", "ι", "κ", "λ", "μ", _
    "ν", "ξ", "ο", "π", "ρ", "σ", "τ", "υ", "φ", "χ", "ψ", "ω", " ", "Α", _
    "Β", "Γ", "Δ", "Ε", "Ζ", "Η", "Θ", "Ι", "Κ", "Λ", "Μ", "Ν", "Ξ", _
    "Ο", "Π", "Ρ", "Σ", "Τ", "Υ", "Φ", "Χ", "Ψ", "Ω", "/", """, _
    "'", "ά", "έ", "ί", "ή", "ύ", "ό", "ώ")
 
    Dim Eng As Variant
    Eng = Array("a", "v", "g", "d", "e", "z", "i", "th", "i", "k", "l", _
   "m", "n", "ks", "o", "p", "r", "s", "t", "y", "f", "x", "ps", "w", "-", _
   "A", "V", "G", "D", "E", "Z", "I", "TH", "I", "K", "L", "M", "N", _
   "KS", "O", "P", "R", "S", "T", "Y", "F", "X", "PS", "W", "-", "-", _
    "-", "a", "e", "i", "i", "y", "o", "w")
     
    For I = 1 To Len(Txt)
        с = Mid(Txt, I, 1)
     
        flag = 0
        For J = 0 To 65
            If Gr(J) = с Then
                outchr = Eng(J)
                flag = 1
                Exit For
            End If
        Next J
        If flag Then outstr = outstr & outchr Else outstr = outstr & с
    Next I
     
    Translit = outstr 
End Function
 
22.12.2015 12:56:16
Здравствуйте!
Вначале функция работала корректно, но через пару дней стала не находить какую-то библиотеку.
Помогите, пожалуйста.


https://www.dropbox.com/s/oflpcld5pyfm33f/%D0%A1%D0%BA%D1%80%D0%B8%D0%BD%D1%88%D0%BE%D1%82%202015-12-22%2012.52.49.png?dl=0
27.05.2016 16:33:07
Доброго времени суток!
Подскажите что необходимо прописать что бы при нажатии CommandButton текст на русском из TextBox переносился транслитом в заданную ячейку листа?
В модуль добавил текст функции из шапки.
Я самоучка и еще многого не понимаю и не знаю, строго не судите)

я прописал так - 'Заносим данные из TextBox26 транслитом.
   ActiveSheet.Cells(lLastRow, "H";).Value = Module6.Translit(Me.TextBox26)

выдает ошибку в Модуле и подсвечивает символ "i" в строке For i = 1 To Len(Txt)

И если в  TextBox будут текст + цифры, также выдает ошибку в строке If Rus(j) = с Then . Что необходимо поправить?

спасибо!
02.07.2016 16:57:18
Добрый день! Как можно при транслитерации заменить пробел на тире?

Разобрался.
Добавил в RUS  , " ", "%"
Добавил в ENG  , "-", ""
и изменил For J = 0 To 65 на 67