Транслитерация в ином ракурсе

[vadim245]

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

[Vikar]

Могу предложить следующий алгоритм.
Пробегаешь по всем выделенным ячейкам. Если в очередной ячейке находится текст, то запоминаешь его в переменной (например s). Затем эту переменную s обрабатываешь по своему словарю транслитерации. Для этого, на мой взгляд, удобно использовать две константы. В одной все сиволы одного алфавита, в другй, на соответвствующих местах, символы другого алфавита. Например "абвгд...АБВГД..." и "abvgd...ABVGD...". В цикле вырезаешь из переменной s очередной символ, находишь его позицию в первой константе, а затем меняешь его на символ который находится под этим же номером в второй константе (стоит предусмотреть действия на случай если такого символа нет в первой константе). После обработки переменной s ее новое значение возвращаешь в ту ячейку таблицы из которой читал.

[vadim245]

Написали такую функцию:

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

 
Function Translit$(iValue$)
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
iValue$ = Application.Substitute(LCase(iValue$), _
Mid(iRussian$, iCount%, 1), iTranslit(iCount%)) 'MS Excel 97
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
iValue$ = Replace(iValue$, Mid(iRussian$, iCount%, 1), _
iTranslit(iCount%), , , vbTextCompare) 'MS Excel 2000
Next
Translit$ = StrConv(iValue$, vbProperCase) 'Ivan Taranov
End Function

А вот макрос, который ее использует

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

 
Sub IspTranslit()
For Each cell In Selection
cell.Value = Translit(cell.Value)
Next
End Sub

Вопрос - как решить проблему:
ул. Ленина -> Ul Lenina

а надо, чтобы было с соблюдением оригинального регистра:
ул. Ленина -> ul. Lenina

[Игорь Акопян]

пробить полный список букв и убрать вызов StrConv

[vadim245]

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

Function Translit$(iValue$)
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", "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 65
iValue$ = Replace(iValue$, Mid(iRussian$, iCount%, 1), iTranslit(iCount%), , , vbTextCompare) 'MS Excel 2000
Next
Translit$ = iValue$
End Function


Sub IspTranslit()
For Each cell In Selection
cell.Value = Translit(cell.Value)
Next
End Sub

Где я протупил? Теперь все заглавными.

[Vikar]

Скорее всего надо в замене последний параметр установить - сравнить как бинарные значения, а не как текст.

[Aent]

Именно так. Последним параметров в Replace надо указать vbBinaryCompare.
У вас же указан текстовый режим сравнения. Поэтому строчная буква успешно
сопоставлялась с заглавной ...

[vadim245]

Ура! Заработало
Спасибо, дело было действительно
в этом параметре

[NoComm]

Спасибо за код.. Очень пригодился.. ))

Кстати, советую цикл продолжать до "66", а не до "65"
Иначе, если кто не заметил, "я" не обрабатывается..

PS: ..и я б все-таки, немного другие сочетания букв подставлял, но это уже, наверное, дело привычки..