На работе была забита база данных приборов. Забивали эту базу в excel люди неопытные. В названиях приборов и обозначениях смешались русские и латинские символы. Мне для нормальной работы сей бардак необходимо исправить. Перезабивать бвзу в 12853 наименований нехочется. Подскажите пожалуйста как поступить.
1. меню-правка-заменить... А (латинское) на А (русское) и так весь алфавит <BR>2. малость переделать макрос предложенный здесь: http://www.planetaexcel.ru/tip.php?aid=110
Взял макрос с этого форума, и чуть переделал. Первый красит в красный все латинские символы в выделении. Второй красит в зелёный все русские. А третий объединяет первые два макроса, то есть красит все в свои цвета.
Просто, но удобно. :) Наглядно видно вкрапление русских или латинских букв в инородный текст.
Чтобы вернуть цвет, надо опять выделить и символы закрасит чёрным.
Я использую похожий макрос: 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, но оформлено чуть по-другому
Може и я на что... 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} может хоть за символическую плату кто откликнется? Ведь уже даже код макроса выложен в сеть, насколько я понимаю - дело за малым. Заранее благодарю!
Сергей уже выслал. Не получали? Если не знаете, как применить - посмотрите в "приёмах" на главной странице - там кажется где-то есть описание... Тут (даже в картинках): http://www.planetaexcel.ru/tip.php?aid=122
на счет Сергея - не понял, но ничего я не получал. Касательно ссылки - спасибо огромное, нашел. Но там нет описания создания макроса именно с заменой букв. Или я не так искал? Определить я их могу даже просто поменяв шрифт с отсутствующими русскими символами. Но это муторно, хотелось бы макрос именно с заменой. Буду продолжать поиски, если вдруг у кого такой есть, прошу отписаться, буду мониторить эту тему.
{quote}{login=nOXX}{date=02.02.2012 08:04}{thema=}{post} ...буду мониторить эту тему.{/post}{/quote}Сильно сказано:-) Пришлите свой файл в личку, посмотрю.
:) А вот и тот Сергей :) Ладно, с "письмом от Сергея" я поспешил - этот код другое делает, только что проверил. Серёга, мог бы там и написать, что он меняет asdfghjkl на фывапролд и наоборот :) И даже если заменить эти две строки так:
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!!!)
{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:-) Хотя, при посимвольной оплате...