UncleFather » 27 янв 2013 10:22, Вс
Проблема:
Необходимо конвертировать содержимое ячейки 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
[b][size=150]Проблема:[/size][/b]
Необходимо конвертировать содержимое ячейки MS Excel в транслит (транслитерация). Как вариант - заменить символы в ячейке на другие по определенной схеме.
[b][size=150]Решение:[/size][/b]
[list=1][*] Открываем MS Visual Basic For Applications из MS Excel (Alt+F11)
[*] В текущей книге или в личной книге макросов создаем новую функцию (просто вставляем содержимое) [url=http://www.planetaexcel.ru/techniques/7/32/]источник[/url]:
[spoiler title=код функции:][code]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[/code][/spoiler]
получится примерно так:
[attachment=2]02.jpg[/attachment]
[*] Сохраняем книгу (Ctrl+S)
[*] Переходим в MS Excel
[*] В ячейку, куда нужно поместить транслитерированный текст, вставляем новую функцию:
[attachment=1]01.jpg[/attachment]
Получается как-то так:
[attachment=0]03.jpg[/attachment][/list]
[b][size=150]Вариант:[/size][/b]
Нужно заменить русские символы в ячейке на английские так, чтобы это соответствовало раскладке клавиатуры (например: [i]q-й, w-ц, e-у, r-к, t-е, y-н, u-г[/i]...)
Повторяем все вышеописанные шаги, но вместо приведенного там текста функции, вставляем [spoiler title=новый код функции:][code]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
[/code][/spoiler]