MS Excel. Преобразование в транслит

Настройки MS Office, Open Office и пр. офисного ПО. Полезные советы и пр. То, чего не найдешь в бескрайних просторах Интернета. Решения тех проблем, которые не решаются типовыми ответами, которые можно получить в техподдержке Майкрософта - а именно: переустановить продукт или купить какой-ть другой лицензионный диск.


Модератор: UncleFather

Аватара пользователя
UncleFather
Site Admin
Сообщения: 1505
Зарегистрирован: 17 авг 2004 16:20, Вт
Контактная информация:

MS Excel. Преобразование в транслит

Сообщение UncleFather »

Проблема:

Необходимо конвертировать содержимое ячейки MS Excel в транслит (транслитерация). Как вариант - заменить символы в ячейке на другие по определенной схеме.

Решение:

  1. Открываем MS Visual Basic For Applications из MS Excel (Alt+F11)

  2. В текущей книге или в личной книге макросов создаем новую функцию (просто вставляем содержимое) источник:

    код функции:

    Код: Выделить всё

    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

    получится примерно так:

    02.jpg
  3. Сохраняем книгу (Ctrl+S)

  4. Переходим в MS Excel

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

    01.jpg

    Получается как-то так:

    03.jpg

Вариант:

Нужно заменить русские символы в ячейке на английские так, чтобы это соответствовало раскладке клавиатуры (например: q-й, w-ц, e-у, r-к, t-е, y-н, u-г...)

Повторяем все вышеописанные шаги, но вместо приведенного там текста функции, вставляем

новый код функции:

Код: Выделить всё

Function TranslitKeyb(Txt As String) As String

    Dim Rus As Variant

    Rus = Array("é", "ö", "ó", "ê", "å", "í", "ã", "ø", "ù", "ç", "õ", "ú", _
    "ô", "û", "â", "à", "ï", "ð", "î", "ë", "ä", "æ", "ý", "ÿ", "÷", "ñ", _
    "ì", "è", "ò", "ü", "á", "þ", "¸", "É", "Ö", "Ó", "Ê", "Å", "Í", _
    "Ã", "Ø", "Ù", "Ç", "Õ", "Ú", "Ô", "Û", "Â", "À", "Ï", "Ð", _
    "Î", "Ë", "Ä", "Æ", "Ý", "ß", "×", "Ñ", "Ì", "È", "Ò", "Ü", "Á", "Þ", "¨")
 
    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", _
    "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", "<", ">", "~")
     
    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
     
    TranslitKeyb = outstr
     
End Function

Alexander A. Manaeff©

Понравилась статья? Будем крайне признательны за репосты в соцсетях! Материально поддержать проект можно здесь

Мои странички:
ВКонтакте
Одноклассники
Youtube
Facebook
Instagram

Изображение
Изображение
Изображение
Изображение