Замена английских символов на русский шрифт одним щелчком, или - боже, благослови VBA! При получении данных из таблиц с помощью ВПР или ИНДЕКС важное значение имеет тип данных и языковая раскладка, с помощью которой набрано название. И если для смены типа можно использовать встроенные функции Excel, то с шрифтом все не так просто. По крайней мере, если решать задачу в лоб, то формула получится достаточно громоздкой. Давайте решим эту проблему, используя возможности VBA, или – проще – возможности макросов. Для этого вначале попробуем определить, какие именно знаки латинского алфавита похожи на русский и запишем их в виде строки
Получаем такой код Dim LatStr As String: LatStr = "EeOoPpAaXxCcMTHKB"
Как видим, таких знаков не так уж и много Добавим соответствующие им символы кириллицы Dim RusStr As String: RusStr = "ЕеОоРрАаХхСсМТНКВ"
Напоминаю, в первой строке все буквы латинские (английские, если вам так проще), а во второй – кириллица, то есть русские. Названия произвольны. Обратите внимание, что знаки, похожие по написанию, находятся на одинаковых местах. Логика тут следующая. Если один из знаков проверяемого текста совпадает с знаком из строки LatStr, то надо взять аналогичный знак из RusStr Для этого назначим для проверяемой строки переменную TestString. К примеру, возьмем его из текущей ячейки Dim TestString as string: TestString=ActiveCell.Value После этого начнем по очереди сравнивать каждый символ полученной строки с латиницей из LatStr. Запускаем цикл для получения очередного знака из TestString. Вначале объявим переменные хранения счетчиков циклов, а также очередных знаков из TestString и LatStr. Так же зададим переменную типа строка для результата обработки NewString
Dim b as integer, J as integer, sValue as string, s1 as string, NewString as string
Запустим сам цикл For j=1 to Len(TestString) sValue=Mid(TestString,j,1) теперь начнем так же в цикле сравнивать его с знаками из LatStr. Если такой знак отыщется, то берем соответствующий знак из RusStr For b=1 to Len(LatStr) S1=mid(LatStr,b,1) If s1=SValue then SValue=Mid(RusStr,b,1) Закрываем цикл сравнения и вернемся к проверке очередного знака. Next b В итоге, если буква была латинской, она заменится на соответствующую по написанию русскую, если нет - знак остается прежним. Добавим полученный результат к некоей строке NewString. Изначально наша переменная, как и любая другая, буде пустой, но посте каждого прохождения цикла тестирования к ней будет добавляться очередной символ NewString=NewString & sValue И закрываем цикл извлечения Next j В результате получили такой итоговый код
Dim TestString as string: TestString=ActiveCell.Value Dim LatStr As String: LatStr = "EeOoPpAaXxCcMTHKB" Dim RusStr As String: RusStr = "ЕеОоРрАаХхСсМТНКВ" Dim b as integer, J as integer, sValue as string, s1 as string For j=1 to Len(TestString) sValue=Mid(TestString,j,1) For b=1 to len(LatStr) S1=mid(LatStr,b,1) If s1=sValue then sValue=Mid(RusStr,b,1) Next b NewString=NewString & sValue Next j Отступы могут быть произвольными, можно вообще обойтись без них, но так проще отследить, что же происходит на участках кода Где же применить полученный код? Лично я вижу два варианта. Первый - обернуть строки кода в виде функции. Например, создать пустой файл Excel, открыть в нем редактор VBA, используя нажатие сочетания “Alt F11” и дать команду «Insert» → «module!»
В открывшемся окне надо вставить следующее Public Function LatinToRus (TestString as Variant) as string Редактор автоматически создаст основу или – как принято это называть – каркас для функции, добавив строку End Function. После этого добавим полученный нами выше код перед строкой End Function, но первую строку кода пропускаем – мы задаем TestString как параметр – исходные данные – для нашей функции. Завершим все добавлением строки LatinToRus=NewString
Результат получится таким
Public Function LatinToRus (TestString as Variant) as string Dim LatStr As String: LatStr = "EeOoPpAaXxCcMTHKB" Dim RusStr As String: RusStr = "ЕеОоРрАаХхСсМТНКВ" Dim b as integer, J as integer, sValue as string, s1 as string For j=1 to Len(TestString) sValue=Mid(TestString,j,1) For b=1 to len(LatStr) S1=mid(LatStr,b,1) If s1=Svalue then Svalue=Mid(RusStr,b,1) Next b NewString=NewString & sValue Next j LatinToRus=NewString End Function
Название функции естественно может быть произвольным Теперь сохраним наш файл как надстройку Excel в формате Xlam. Excel сам автоматически выберет место для хранения надстройки, поэтому если вы хотите сохранить ее резервную копию, проще будет не искать ее, а дать команду «Сохранить как» ещё раз и сделать копию к примеру на рабочем столе
Теперь перейдем по пути Файл → параметры → Надстройки → надстройки Excel → перейти И отмечаем нашу надстройку флажком
После этого функция станет доступной во всех файлах Excel для текущего пользователя в категории «Определенные пользователем»
А вот и пример использования.
Обратите внимание на формулы. Очевидно, что после применения функции LatinToRus были найдены все слова по образцам Второй способ примененияы – использование созданного кода в виде процедуры, например, для яеек выделения. Такую процедуру удобнее добавить в личную книгу макросов. Изначально доступ к ней запрерщен, поэтоиу пойдем на хитрость. Запустим запись макроса с вкладки «Вид»
Укажем хранение макроса в личной книге, после чего сразу остановим запись
Снова запускаем редактор VBA и открываем текст модуля из личной книги.
Удаляем строки Sub Макрос1 () и End Sub а так же все что Excel добавил между ними и вставляем следующий код Sub Change_Latin_To_Rus() Dim LatStr As String: LatStr = "EeOoPpAaXxCcMTHKB" Dim RusStr As String: RusStr = "ÅåÎîÐðÀàÕõÑñÌÒÍÊÂ" Dim b As Integer, J As Integer, sValue As String, s1 As String Dim TestString As String For Each MyCells In Selection NewString = "" TestString = MyCells.Value For J = 1 To Len(TestString) sValue = Mid(TestString, J, 1) For b = 1 To Len(LatStr) s1 = Mid(LatStr, b, 1) If s1 = sValue Then sValue = Mid(RusStr, b, 1) Next b NewString = NewString & sValue Next J MyCells.Value = NewString Next MyCells End Sub
Теперь достаточно выделить нужный диапазон, нажать сочетание Alt F8 и выбрать нашу процедуру Замена произойдет автоматически во всех выделенный ячейках. И наконец ,если вам надо наоборот поменять русские буквы в латинице, то просто поменяйте местами в циклах LatStr и RusStr то есть сделайте так For b=1 to len(RusStr) S1=mid(RusStr,b,1) If s1=Svalue then Svalue=Mid(LatStr,b,1) Next b Наконец, никто не мешает добавить символы, к примеру, заменить знак нуля на заглавную букву «О». то есть дальнейшее уже зависит от вашей фантазии. Пробуйте, экспериментируйте. На этом все, встретимся на занятиях. Всем внимательности и упорства, а удача придет тогда сама
| |
| |
Просмотров: 298 | | |
Всего комментариев: 0 | |