Проблема:
Необходимо конвертировать содержимое ячейки MS Excel в транслит (транслитерация). Как вариант - заменить символы в ячейке на другие по определенной схеме.
Решение:
-
Открываем MS Visual Basic For Applications из MS Excel (Alt+F11)
-
В текущей книге или в личной книге макросов создаем новую функцию (просто вставляем содержимое) источник:
код функции:
Код: Выделить всё
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
получится примерно так:
-
Сохраняем книгу (Ctrl+S)
-
Переходим в MS Excel
-
В ячейку, куда нужно поместить транслитерированный текст, вставляем новую функцию:
Получается как-то так:
Вариант:
Нужно заменить русские символы в ячейке на английские так, чтобы это соответствовало раскладке клавиатуры (например: 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