Транслит

33717 14.09.2012 Скачать пример

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

Откройте редактор 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):

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

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

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

Иван Иванов

22.09.2012 22:58:41

Ух ты, спасибо!

Ссылка

Бескаравайная Елена

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

Во-первых, с такими вопросами лучше на форум все-таки. Во-вторых, такое только макросами. В-третьих, насчет автоматического переключения языка в нужном столбце я сильно сомневаюсь

Родитель Ссылка

lis2109

08.01.2014 11:10:47

http://excelvba.ru/code/KeyboardLayout

Родитель Ссылка

numer numer

26.03.2014 12:48:27

Доброго времени суток Есть ли переводчик с украинского на русский !!!

Ссылка

Николай Павлов

16.11.2014 09:43:30

Это не переводчик, а транслитератор. Если нужно, то просто замените русские символы в коде на украинские и их аналоги на латинице.

Родитель Ссылка

Александр Хмельницкий

01.03.2020 02:52:44

Добрый день Николай.

Да работает, но в украинской транслитерации есть одно исключение:
Сочетание букв “зг” транслитерируется латиницей как “zgh”
это связано с тем что “ж” транслитерируется “zh” и если делать замену по буквам “з”-"z", “г”-"h" то получается "ж", а не "зг".

Я пробовал доработать Вашу функцию под украинский язык, все получается кроме выше описанного исключения. Можете помощь в решении этой задачи, заодно и в Вашу надстройку PLEX можно будет добавить новую функцию транслитерации с украинского на английский.

Function Translit2(Txt As String) As String
 
 Dim Ukr As Variant
 Ukr = Array("ЗГ", "а", "б", "в", "г", "ґ", "д", "е", "є", "ж", "з", "і", "ї", "й", "к", _
 "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
 "щ", "и", "ь", "ю", "я", "А", "Б", "В", "Г", "Ґ", "Д", "Е", _
 "Є", "Ж", "З", "І", "Ї", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
 "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "И", "Ь", "Ю", "Я", " ", "'";)
 Dim Eng As Variant
 Eng = Array("ZGH", "a", "b", "v", "h", "g", "d", "e", "ie", "zh", "z", "i", "i", "i", "k", _
 "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "ch", "sh", _
 "shch", "y", "", "іu", "ia", "A", "B", "V", "H", "G", "D", "E", _
 "Ye", "Zh", "Z", "I", "Yi", "Y", "K", "L", "M", "N", "O", "P", "R", _
 "S", "T", "U", "F", "Kh", "Ts", "Ch", "Sh", "Shch", "Y", "", "Yu", "Ya", " ", "";)
 'Как написать змену "ЗГ" на "ZGH"
 For i = 1 To Len(Txt)
 c = Mid(Txt, i, 1)

 flag = 0
 For j = 0 To UBound(Ukr)
 If Ukr(j) = c Then
 outchr = Eng(j)
 flag = 1
 Exit For
 End If
 Next j
 If flag Then outstr = outstr & outchr Else outstr = outstr & c
 Next i
 
Translit2 = outstr
End Function

На ходил еще такое решение, но совместить его с Вашей формулой у меня не получается

Translit3$(iValue$)
    Translit3$ = StrConv(iValue$, vbProperCase)
    Translit3$ = Replace(Translit3$, "зг", " zgh ", , , vbTextCompare)

Родитель Ссылка

Алексей

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 и превращать их в транслит.

Родитель Ссылка

Sensey Master

24.07.2020 12:54:24

а если наоборот? из русских на латиницу?

Родитель Ссылка

Алина

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

Родитель Ссылка

Евгения Листопадова

14.08.2015 15:58:45

В Экселе 2013 года не могу найти в функциях категорию "Определенные пользователем", следовательно, не могу применить макрос. Помогите, пожалуйста, в поиске))

Ссылка

DrBraun

15.09.2015 14:23:12

Подскажите, как сделать, чтобы в место пробела вставлялось нижнее подчеркивание?

Ссылка

Alex Greet

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

Ссылка

Роман Якимов

24.01.2019 09:36:13

Добрый день!
Возможно в данный макрос добавить аббревиатуры?
Например сделать транслитерацию ООО как Ltd?

Ссылка

Сергей

12.03.2019 11:49:51

Добрый день!

Немного пришлось изменить функцию , все работает но не пойму почему вместо С (лат.) получается М (кир.) и дальше все со сдвигом.
Или может есть другой вариант решения такого вопроса.
Помогите новичку. Спасибо.

Function Translit(Txt As String) As String

Dim Eng As Variant
Eng = Array("q", "w", "e", "r", "t", "y", "u", "i", "o", "p", "[", _
"]", "a", "s", "d", "f", "g", "h", "j", "k", "l", ";", "'", "z", "x", _
"x", "c", "v", "b", "n", "m", ",", ".", "Q", "W", "E", "R", "T", _
"Y", "U", "I", "O", "P", "[", "]", "A", "S", "D", "F", "G", "H", _
"J", "K", "L", ";", "'", "Z", "X", "C", "V", "B", "N", "M", ",", "."

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

For I = 1 To Len(Txt)
с = Mid(Txt, I, 1)

flag = 0
For J = 0 To 64
If Eng(J) = с Then
outchr = Rus(J)
flag = 1
Exit For
End If
Next J
If flag Then outstr = outstr & outchr Else outstr = outstr & с
Next I

Translit = outstr
End Function

Ссылка

Алиса avalx

05.01.2021 06:17:20

Добрый день! очень хорошая и нужная функция! Подскажите, может ли она не срабатывать из-за того, что excel только на английском (надстройки русского языка нет). Просто даже ваш пример скачала и у меня транслит срабатывает на язык образца. "Петя-->Петя". "Niky-->Niky".
хотя русскийпакет уже скачала, но ситуация та же...
Заранее спасибо за ответ!

Ссылка

Musaka

20.03.2024 16:55:48

Добрый день!
Тоже очень нужна такая функция, чтобы транслитерировать 59 тысяч строк.
И такая же проблема: функция работает, но трансформирует кириллицу в кириллицу и латиницу в латиницу, а вот кириллицу в латиницу не переводит. Возможно это как-то связано с настройками самого устройства/Windows, т.к. мое устройство изначально активировано не в РФ.
Спасибо заранее за ответ!

Родитель Ссылка

Дмитрий Шипилов

13.10.2023 11:13:57

Если требуется перевести кириллицу в транслит для создания URL адреса, пример:
Исходный текст: ТБХ ПЕРФОРАТОР "Сан-Мастер" гранулированное / средство для прочистки труб! 500гр.
Результат: TBKH-PERFORATOR-San-Master-granulirovannoe--sredstvo-dlya-prochistki-trub-500gr

Макрос работает но, написан не профессионалом в VBA:

Function Translit(Txt As String) As String
Dim Rus As Variant
Dim Eng As Variant
Dim с As String
Dim outstr As String
Dim outchr As String
Dim flag As Integer
Dim J As Integer
Dim I As Integer

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

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)

If с = "-" Then
If I = 1 Or I = Len(Txt) Then
' Если символ - в начале или конце текста, пропускаем его
GoTo ContinueLoop
ElseIf Mid(Txt, I + 1, 1) = "-" Then
' Если следующий символ тоже дефис, пропускаем его
I = I + 1
Else
outstr = outstr & с
End If
ElseIf с = "'" Or с = """" Or с = "/" Or InStr(".,:;!?()[]{}", с) > 0 Then
' Если символ входит в этот список, пропускаем его
GoTo ContinueLoop
ElseIf с = " " Then
' Если символ - пробел, ' или ", заменяем его на дефис
outstr = outstr & "-"
Else
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 & с
End If
End If

ContinueLoop:
Next I

' Удаляем дефис в конце текста
If Right(outstr, 1) = "-" Then
outstr = Left(outstr, Len(outstr) - 1)
End If

Translit = outstr

End Function

Ссылка