Страницы: 1
RSS
о переименовании русских букв в латинские, борьба с транслитом
 
На работе была забита база данных приборов. Забивали эту базу в excel люди неопытные. В названиях приборов и обозначениях смешались русские и латинские символы.  
Мне для нормальной работы сей бардак необходимо исправить.  
Перезабивать бвзу в 12853 наименований нехочется. Подскажите пожалуйста как поступить.
 

1. меню-правка-заменить... А (латинское) на А (русское) и так весь алфавит <BR>2. малость переделать макрос предложенный здесь: http://www.planetaexcel.ru/tip.php?aid=110

 
Взял макрос с этого форума, и чуть переделал.  
Первый красит в красный все латинские символы в выделении.  
Второй красит в зелёный все русские.  
А третий объединяет первые два макроса, то есть красит все в свои цвета.    
 
Просто, но удобно. :)  
Наглядно видно вкрапление русских или латинских букв в инородный текст.  
 
Чтобы вернуть цвет, надо опять выделить и символы закрасит чёрным.  
 
Sub ShowLatinas()  
For Each c In Selection  
   For i = 1 To Len©  
       k = Asc(Mid(c, i, 1))  
       If (k >= 65 And k <= 90) Or _  
              (k >= 97 And k <= 122) Then  
               c.Characters(Start:=i, Length:=1).Font.ColorIndex = 3  
       End If  
   Next i  
Next c  
End Sub  
 
Sub ShowRus()  
For Each c In Selection  
   For i = 1 To Len©  
       k = Asc(Mid(c, i, 1))  
       If (k >= 192 And k <= 255) Then  
               c.Characters(Start:=i, Length:=1).Font.ColorIndex = 4  
       End If  
   Next i  
Next c  
End Sub  
 
Sub ColorAll()  
For Each c In Selection  
   For i = 1 To Len©  
       k = Asc(Mid(c, i, 1))  
       If (k >= 192 And k <= 255) Then  
               c.Characters(Start:=i, Length:=1).Font.ColorIndex = 4  
       Else  
         If (k >= 65 And k <= 90) Or _  
              (k >= 97 And k <= 122) Then  
               c.Characters(Start:=i, Length:=1).Font.ColorIndex = 3  
         End If  
       End If  
   Next i  
Next c  
End Sub
 
Я использую похожий макрос:  
Sub Color_RUS_LAT()  
  Dim iCell As Range, rRange As Range, i%, ASCII%, iColor%  
  Set rRange = Intersect(Selection, UsedRange)  
  If rRange Is Nothing Then Exit Sub  
  Application.ScreenUpdating = False  
  For Each iCell In rRange  
     For i = 1 To Len(iCell)  
        ASCII = Asc(Mid(iCell, i, 1))  
        If (ASCII >= 192 And ASCII <= 255) Then iColor = 4   'цвет символов РУС  
        If (ASCII >= 65 And ASCII <= 90) Or (ASCII >= 97 And ASCII <= 122) Then iColor = 3   'цвет символов LAT  
        iCell.Characters(Start:=i, Length:=1).Font.ColorIndex = iColor  
     Next i  
  Next iCell  
  rRange.Select  
  Application.ScreenUpdating = True  
End Sub  
 
принцип работы - такой же, как и у 3-го макроса AlexeyE30, но оформлено чуть по-другому
 
пока вводил, разлогигился...  
Это был я.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
а зачем красить?  
менять сразу по таблице подстановки
 
Може и я на что...  
Sub ChangeEngRus()  
' Макрос2 Макрос  
' Макрос записан 05/10/2000 (Sergey P)  
' с изрядной долей плагиата  
Dim c As Object  
Dim n As Integer, i As Integer, posChar As Integer  
Dim ToRusLang As Boolean  
Dim LineChars(1) As String * 72  
Dim Ch As String * 1  
Dim TempSelection As String  
LineChars(0) = "qwertyuiop[]asdfghjkl;'zxcvbnm,.`QWERTYUIOP{}ASDFGHJKL:" + Chr(34) + "ZXCVBNM<>~@#$%^&"
LineChars(1) = "йцукенгшщзхъфывапролджэячсмитьбюёЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧС­МИТЬБЮЁ" + Chr(34) + "№;%:?"  
For Each c In Selection.Cells  
TempSelection = c.Value  
ToRusLang = True  
For i = 1 To Len(TempSelection)  
   Ch = Mid(TempSelection, i, 1)  
   If ToRusLang Then n = 0 Else n = 1  
   posChar = InStr(LineChars(n), Ch)  
   If posChar = 0 Then  
       n = Abs(n - 1)  
       posChar = InStr(LineChars(n), Ch)  
   End If  
   If posChar <> 0 Then  
           Select Case n  
               Case 0  
                   ToRusLang = True  
               Case 1  
                   ToRusLang = False  
           End Select  
       Mid(TempSelection, i, 1) = Mid(LineChars(Abs(n - 1)), posChar, 1)  
   End If  
Next  
c.Value = TempSelection  
Next c  
End Sub
Я сам - дурнее всякого примера! ...
 
Я как-то в Access'e делал защиту от оболтусов, которым при вводе условных обозначений (должны быть только латинские буквы и цифры) лень менять имеющуюся в момент ввода раскладку клавы, если буквы русские и латинские выглядят одинаково... (вводили вместо латинских A русские А, вместо B - В, E - Е и т.д.).  
Это делалось автозаменой при вводе в окно формы, но можно элементарно переделать это в макрос Ёкселя, обрабатывающий выделенный диапазон...  
Если кому-то надо, то я могу тот макрос вытащить из базы данных и адаптировать его под Ёксель
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
{quote}{login=}{date=15.06.2010 04:39}{thema=}{post}а зачем красить?  
менять сразу по таблице подстановки{/post}{/quote}  
всем доброго дня! А может кто поделиться этим макросом? Писать не умею, посему обращаюсь к профессионалам. Задача обычная - чтобы на выбранном массиве данных (например - кусок таблицы или выделенные строки/столбцы) сделать автозамену всех схожих букв (английскую A на русскую А и т.д.).    
В работе сейчас более 80 документов с такими ошибками. Посему, задача не простая, требует автоматизации.
 
{quote}{login=nOXX}{date=01.02.2012 07:22}{thema=Re: }{post}{quote}{login=}{date=15.06.2010 04:39}{thema=}{post}а зачем красить?  
менять сразу по таблице подстановки{/post}{/quote}  
всем доброго дня! А может кто поделиться этим макросом? Писать не умею, посему обращаюсь к профессионалам. Задача обычная - чтобы на выбранном массиве данных (например - кусок таблицы или выделенные строки/столбцы) сделать автозамену всех схожих букв (английскую A на русскую А и т.д.).    
В работе сейчас более 80 документов с такими ошибками. Посему, задача не простая, требует автоматизации.{/post}{/quote}  
может хоть за символическую плату кто откликнется? Ведь уже даже код макроса выложен в сеть, насколько я понимаю - дело за малым. Заранее благодарю!
 
Ну расскажите нам - как Вы представляете себе это "поделиться"?
 
{quote}{login=Hugo}{date=02.02.2012 05:33}{thema=}{post}Ну расскажите нам - как Вы представляете себе это "поделиться"?{/post}{/quote}  
выслать макрос
 
Сергей уже выслал. Не получали? Если не знаете, как применить - посмотрите в "приёмах" на главной странице - там кажется где-то есть описание...  
Тут (даже в картинках):  
http://www.planetaexcel.ru/tip.php?aid=122
 
{quote}{login=Hugo}{date=02.02.2012 06:36}{thema=}{post}Сергей уже выслал...{/post}{/quote}:-)
Я сам - дурнее всякого примера! ...
 
на счет Сергея - не понял, но ничего я не получал.  
Касательно ссылки - спасибо огромное, нашел. Но там нет описания создания макроса именно с заменой букв. Или я не так искал? Определить я их могу даже просто поменяв шрифт с отсутствующими русскими символами. Но это муторно, хотелось бы макрос именно с заменой. Буду продолжать поиски, если вдруг у кого такой есть, прошу отписаться, буду мониторить эту тему.
 
{quote}{login=nOXX}{date=02.02.2012 08:04}{thema=}{post}  
...буду мониторить эту тему.{/post}{/quote}Сильно сказано:-) Пришлите свой файл в личку, посмотрю.
Я сам - дурнее всякого примера! ...
 
:)  
А вот и тот Сергей :)  
Ладно, с "письмом от Сергея" я поспешил - этот код другое делает, только что проверил. Серёга, мог бы там и написать, что он меняет asdfghjkl на фывапролд и наоборот :)  
И даже если заменить эти две строки так:  
 
LineChars(0) = "achopetmkACHOPETMK"  
LineChars(1) = "асноретмкАСНОРЕТМК"  
 
то от этого толку нет - будет просто наоборот... из Сaша будет Cашa :(
 
Sub ChangeEngRus_CcEeTOopPAaHKkXxBM()  
   Dim c As Object  
   Dim n As Integer, i As Integer, posChar As Integer  
   Dim ToRusLang As Boolean  
   Dim LineChars(1) As String * 72  
   Dim Ch As String * 1  
   Dim TempSelection As String  
   LineChars(0) = "CcEeTOopPAaHKkXxBM"  
   LineChars(1) = "СсЕеТОорРАаНКкХхВМ"  
   For Each c In Selection.Cells  
       TempSelection = c.Value  
       ToRusLang = True  
       For i = 1 To Len(TempSelection)  
           Ch = Mid(TempSelection, i, 1)  
           If ToRusLang Then n = 0 Else n = 1  
           posChar = InStr(LineChars(n), Ch)  
           If posChar = 0 Then  
               n = 0    'Abs(n - 1)  
               posChar = InStr(LineChars(n), Ch)  
           End If  
           If posChar <> 0 Then  
               Select Case n  
               Case 0  
                   ToRusLang = True  
               Case 1  
                   ToRusLang = False  
               End Select  
               Mid(TempSelection, i, 1) = Mid(LineChars(Abs(n - 1)), posChar, 1)  
           End If  
       Next  
       c.Value = TempSelection  
   Next c  
'    Color_RUS_LAT  
End Sub
Я сам - дурнее всякого примера! ...
 
Можно ещё упростить  
Public Sub ChangeEngToRus()  
   Dim engChars As Variant, rusChars As Variant  
   Dim i As Long, FItem As Long, LItem As Long, s As String  
   Dim Funcs As Excel.WorksheetFunction, item As Excel.Range  
   If TypeOf Selection Is Excel.Range Then  
       engChars = Array("C", "c", "E", "e", "T", "O", "o", "p", "P", "A", "a", "H", "K", "k", "X", "x", "B", "M")  
       rusChars = Array("С", "с", "Е", "е", "Т", "О", "о", "р", "Р", "А", "а", "Н", "К", "к", "Х", "х", "В", "М")  
       FItem = LBound(engChars): LItem = UBound(engChars)  
       Set Funcs = Application.WorksheetFunction  
       For Each item In Selection  
           If Not Funcs.IsNonText(item.Value) Then  
               s = item.Value  
               For i = FItem To LItem  
                   s = Replace(s, engChars(i), rusChars(i), Compare:=vbBinaryCompare)  
               Next i  
               item.Value = s  
           End If  
       Next item  
   End If  
End Sub
 
всем мега спасибо! Буду пробовать сейчас. А упрощенная версия файла в приложении. Есть и русские и английские буквы.
 
{quote}{login=nOXX}{date=01.02.2012 07:22}{thema=Re: }{post}{quote}{login=}{date=15.06.2010 04:39}{thema=}{post}а зачем красить?  
менять сразу по таблице подстановки{/post}{/quote}  
... сделать автозамену всех схожих букв (английскую A на русскую А и т.д.).    
{/post}{/quote}Sub ChangeRusEng_CcEeTOopPAaHKkXxBM()Так Вам наоборот менять надо!  
   Dim c As Object, i&, p&, l(1) As String * 72  
   Dim Ch As String * 1, t$  
   l(0) = "CcEeTOopPAaHKkXxBM": l(1) = "СсЕеТОорРАаНКкХхВМ"  
   For Each c In Selection.Cells  
       t = c.Value  
       For i = 1 To Len(t)  
           Ch = Mid(t, i, 1)  
           p = InStr(l(1), Ch)  
           If p <> 0 Then Mid(t, i, 1) = Mid(l(0), p, 1)  
       Next  
       c.Value = t  
   Next c  
End Sub
Я сам - дурнее всякого примера! ...
 
Вот, что я как-то для себя делал (специально сделано двумя разными методами:  
Sub Repair_RUS()   ' заменить латинские буквы такими же по начертанию русскими  
   If TypeName(Selection) <> "Range" Then Exit Sub  
   Dim LATChr$: LATChr = "CcEeTOopPAaHKkXxBM"  
   Dim RUSChr$: RUSChr = "СсЕеТОорРАаНКкХхВМ"  
   Dim i%  
   For i = 1 To Len(LATChr)  
       Intersect(Selection, ActiveSheet.UsedRange).Replace _  
               What:=Mid(LATChr, i, 1), _  
               Replacement:=Mid(RUSChr, i, 1), _  
               LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True  
   Next i  
End Sub  
Sub Repair_LAT()   ' заменить русские буквы такими же по начертанию латинскими  
   If TypeName(Selection) <> "Range" Then Exit Sub  
   Dim arrENG(): arrENG = Array("C", "c", "E", "e", "T", "O", "o", "p", "P", "A", "a", "H", "K", "k", "X", "x", "B", "M")  
   Dim arrRUS(): arrRUS = Array("С", "с", "Е", "е", "Т", "О", "о", "р", "Р", "А", "а", "Н", "К", "к", "Х", "х", "В", "М")  
   Dim i%  
   For i = 0 To UBound(arrENG)  
       Intersect(Selection, ActiveSheet.UsedRange).Replace _  
               What:=arrRUS(i), _  
               Replacement:=arrENG(i), _  
               LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True  
   Next i  
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Леш, а так не слишком: Intersect(Selection, ActiveSheet.UsedRange)? Почему не просто Selection?
Я сам - дурнее всякого примера! ...
 
{quote}{login=KukLP}{date=03.02.2012 07:37}{thema=}{post}Леш, а так не слишком: Intersect(Selection, ActiveSheet.UsedRange)? Почему не просто Selection?{/post}{/quote}Привет, Серёга!  
Извини, долго не отвечал - в топик вчера написАл и забыл, а сегодня  только-только вошёл в сеть...  
 
По твоему вопросу: я так сделал намеренно чтобы можно было выделять целиком столбцы/строки/листы и применять макрос, а уж он сам тогда только по заюзанному диапазону пройдётся.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Леш, можешь сравнить время с интерсектом и без него. Я уверен, результат будет одинаковым. Find не ищет в пустых ячейках. Если хочешь проверь, на пустом листе в Экс 2007-10 введи любую строку в поиск. Результат будет моментально. Таким же он будет, если ввести искомую строку в последнюю ячейку листа и начинать поиск с А1:-) Хотя, при посимвольной оплате...  
 
66344
Я сам - дурнее всякого примера! ...
Страницы: 1
Наверх