Транслитерация текстовой строки средствами VBA

Function Translit(ByVal txt As String) As String
    iRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    iTranslit = Array("", "a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "jj", "k", _
                      "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", _
                      "sh", "zch", "''", "'y", "'", "eh", "ju", "ja")
    For iCount% = 1 To 33
        txt = Replace(txt, Mid(iRussian$, iCount%, 1), iTranslit(iCount%), , , vbTextCompare)
    Next
    Translit$ = txt
End Function

Sub ПримерИспользованияФункцииTranslit()
    txt = "проверка работы транслита"
    newtxt = Translit(txt) ' результат = строка "proverka rabot'y translita"
    MsgBox "Строка """ & txt & """" & vbNewLine & "преобразована в строку """ _
         & newtxt & """", vbInformation, "Результат обработки"
End Sub

Надстройку для транслитерации выделенного диапазона ячеек,
а также расширенную версию функции транслитерации, можно скачать в этой статье

(добавлено в связи с просьбой выполнить обратную транслитерацию)
К сожалению, процесс обратной транслитерации весьма затруднён (я бы даже сказал, что в общем случае невозможно сделать такую функцию, которая преобразовывала бы строку после транслитерации к исходному виду).

Попытаюсь объяснить, почему так происходит:
Допустим, в качестве исходной строки у нас будет текст "щзч схш жзх"

Sub ПримерИспользованияФункцииTranslit()
    txt = "щзч схш жзх"
    newtxt = Translit(txt)
    Debug.Print newtxt    ' результат = строка "zchzch shsh zhzh"

    MsgBox "Строка """ & txt & """" & vbNewLine & "преобразована в строку """ _
           & newtxt & """", vbInformation, "Результат обработки"
End Sub

И что же мы видим на выходе?
А вот что: "zchzch shsh zhzh"

Достаточно похожие сочетания букв, не правда ли?
И как теперь макросу определить, что означает сочетание "zch sh zh" - "щ сх ж" или "зч ш ж"?
Или, может, "зч сх зх"? Все варианты для макроса ведь равнозначны...

А сочетание "zhzh" следует перевести как "зхзх" или как "жж"?
То же самое касается некоторых других буквосочетаний.

Специально проверил транслитерацию подобных сочетаний на популярном сервисе http://www.translit.ru/
Результат - при обратном переводе на русский исходная строка изменилась: схш жзх --> shsh zhzh --> шш жж

Вывод: учитывая возможное количество неопределённостей, проще обратную транслитерацию выполнять вручную.

Другой вариант функции:

Function Translit(ByVal txt As String) As String        ' с учётом регистра символов
    txtRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    arrTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _
                        "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "kh", "ts", "tch", _
                        "sh", "sch", "", "y", "", "e", "yu", "ya")
    For iCount% = 1 To 33
        txt$ = Replace(txt$, Mid(txtRussian$, iCount%, 1), arrTranslit(iCount%), , , vbBinaryCompare)      ' строчные
        txt$ = Replace(txt$, UCase(Mid(txtRussian$, iCount%, 1)), UCase(arrTranslit(iCount%)), , , vbBinaryCompare)     ' прописные
    Next
    Translit$ = txt$
End Function

Результат работы (другой набор символов для замены, учитывается регистр)

Исходная строка: "А-Б-В-Г-Д-Е-Ё-Ж-З-И-Й-К-Л-М-Н-О-П-Р-С-Т-У-Ф-Х-Ц-Ч-Ш-Щ-Ъ-Ы-Ь-Э-Ю-Я"
Итоговая строка: "A-B-V-G-D-E-E-ZH-Z-I-Y-K-L-M-N-O-P-R-S-T-U-F-KH-TS-TCH-SH-SCH--Y--E-YU-YA"

57751 просмотр

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Игорь, 16 Сен 2022 - 18:04.#1

https://disk.yandex.ru/d/51SSaYtvq7044g вот файлом в блокноте
https://youtu.be/OuuTRw2xtBo - по этому видео делал у меня все получилось

Если поможет дайте знать) буду рад!

Игорь, 16 Сен 2022 - 17:54.#2

Вот транслит из английского на русский

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

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

flag = 0
For J = 0 To 65
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

КДО, 13 Апр 2022 - 12:31.#3

Спасибо Вам Добрые люди! Не пришлось изобретать велосипед. Всё работает на отлично!

Игорь (администратор сайта), 12 Апр 2015 - 17:26.#4

можно. с любого языка на любой язык.
в статье есть ссылка на надстройку для транслитерации, - там вы можете сами настроить, какие буквы на какие заменять
(буквы могут быть из любых алфавитов)

Гость, 12 Апр 2015 - 03:21.#5

а как можно Excel-e транслитеровать текст из армянского языка на английский

Гость, 20 Окт 2014 - 20:13.#6

Язык VBA не учил, не работал на нём, поэтому хотел бы узнать мнение специалиста о степени пригодности VBA для создания транслитератора, работающего по правилам систем транслитерации translit1 и translit2 (http://translit1.com/).

Игорь (администратор сайта), 3 Сен 2014 - 19:48.#7

Замените vbTextCompare на vbBinaryCompare - и всё заработает

Gipsy, 3 Сен 2014 - 19:15.#8

Function Translit(ByVal txt As String) As String
iRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюяАБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ"
iTranslit = Array("", "a", "b", "v", "g", "d", "e", "e", "zh", "z", "i", "y", "k", _
"l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "ts", "ch", _
"sh", "sch", "", "y", "", "e", "yu", "ya", "A", "B", "V", "G", "D", _
"E", "E", "Zh", "Z", "I", "Y", "K", "L", "M", "N", "O", "P", "R", "S", _
"T", "U", "F", "H", "Ts", "Ch", "Sh", "Sch", "", "Y", "", "E", "Yu", "Ya")
For iCount% = 1 To 66
txt = Replace(txt, Mid(iRussian$, iCount%, 1), iTranslit(iCount%), , , vbTextCompare)
Next
Translit$ = txt
End Function

Пытался сделать Регистр по другому, ибо перевод в составные большие буквы не устраивает. Ибо имеем вместо "Ч" - "CH", а требуется "Ch"
НО! Не смотря на расширенный массив, всё равно всё переводит в мелкий шрифт.
Подозреваю что нужно писать проверку, но как это делается не знаю.

Гость, 8 Мар 2014 - 01:30.#9

Удобно делать транслитерацию с помощью Punto Switcher, у него есть такая функция, можно назначить сочетание клавиш, например Ctrl+Alt+T и транслитерировать любой выделенный текст (в Экселе в т.ч.) нажав ее.

Klerik97, 7 Июн 2013 - 15:23.#10

Почему же нельзя обратно? Если в начале прогнать на проверку (хотябы основных) сочетания латинских букв и заменить их кириллицей, то оставшиеся символы можно будет прогнать вашим скриптом.

Aleksey, 6 Сен 2012 - 09:47.#11

О, разобрался почему регистр не учитывался в access (в ворде все работало)! :)
вот так теперь учитывается:
txt = Replace(txt, Mid(iRussian$, iCount%, 1), iTranslit(iCount%), , , vbBinaryCompare)
txt = Replace(txt, UCase(Mid(iRussian$, iCount%, 1)), UCase(iTranslit(iCount%)), , , vbBinaryCompare)

Игорь (администратор сайта), 5 Сен 2012 - 21:31.#12

Ну так а вы указали в макросе, что надо преобразовывать текст ячейки?

Попробуйте добавить ниже такие макросы:

Sub ТранслитВыделеннойЯчейки()
    MsgBox "Строка """ & Selection.Cells(1) & """" & vbNewLine & "преобразована в строку """ & Translit(Selection.Cells(1)) & """"
End Sub
 
Sub ТранслитКонкретнойЯчейки() ' для ячейки a1
    MsgBox "Строка """ & [a1] & """" & vbNewLine & "преобразована в строку """ & Translit([a1]) & """"
End Sub
 
Sub ЗаменитьТекстВыделеннойЯчейки() 
    Activecell =  Translit(Activecell)
End Sub

и теперь пробуйте, что вы там делали.

PS: Можете использовать функцию транслита как формулу в ячейке.
К примеру, в ячейке A1 у вас расположен исходный текст.
В ячейке справа напишите формулу =Translit(A1)
и увидите аналогичный результат.

Гость, 5 Сен 2012 - 21:08.#13

Не могу запустить ни один из Ваших макросов.
Win7x64 Office2010x64
В настройках EXCEL
Параметры макросов - Включить все макросы
Доверять доступ к объектной модели проектаVBA
(перезагрузку делал - всего)
Порядок запуска макроса:
1. Копирую с сайта код
2. EXCEL (Alt+F11), Insert > Module, (Ctrl+V), (Ctrl+S), (Alt+Q)-выход
3. EXCEL в формате *.xls
4. Выделяю ячейку с Русским языком (A1)
5. (Alt+F8)-макросы, "ПримерИспользованияФункцииTranslit" > выполнить
6. Показывает
7. Строка "Проверка Работы ТРАНСЛИТА"
Преобразована в строку "Proverka Rabot'y TRANSLITA"
Подскажите что не так? Почему не переводит ячейку?

Гость, 22 Фев 2012 - 13:32.#14

Странно - почему то все равно в нижний регистр все приводит..

Andy, 7 Фев 2012 - 22:05.#15

Это оказывается учтено!

Andy, 7 Фев 2012 - 21:58.#16

Великолепный макрос!!!
А можно сделать, чтобы если в строке содержатся латинские буквы, они бы не преобразовывались.

Игорь (администратор сайта), 16 Июн 2011 - 18:21.#17

Да запросто - теперь и регистр учитывается:

Function Translit(ByVal txt As String) As String ' с учётом регистра символов
     iRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    iTranslit = Array("", "a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "jj", "k", _
                      "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", _
                      "sh", "zch", "''", "'y", "'", "eh", "ju", "ja")
    For iCount% = 1 To 33
        txt = Replace(txt, Mid(iRussian$, iCount%, 1), iTranslit(iCount%)) ' строчные
         txt = Replace(txt, UCase(Mid(iRussian$, iCount%, 1)), UCase(iTranslit(iCount%))) ' прописные
     Next
     Translit$ = txt
End Function
 
Sub ПримерИспользованияФункцииTranslit()
    txt = "Проверка Работы ТРАНСЛИТА"
    newtxt = Translit(txt)    ' результат = строка "Proverka Rabot'y TRANSLITA"
     MsgBox "Строка """ & txt & """" & vbNewLine & "преобразована в строку """ _
         & newtxt & """", vbInformation, "Результат обработки"
End Sub

mat, 16 Июн 2011 - 17:33.#18

Здорово! Хотелось бы еще учет больших-маленьких букв

Транслитерация текстовой строки средствами VBA

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL