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"

• 35487 просмотров