Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос "Color_RUS_LAT" - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "Color_RUS_LAT" (Выделяет РУС-символы в Selection ЗЕЛЁНЫМ, а LAT - КРАСНЫМ)
Макрос "Color_RUS_LAT"
Alex_ST Дата: Суббота, 29.01.2011, 22:49 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3099
Репутация: 581 ±
Замечаний: 0% ±

2003
Для обработки-сведения в общую учётную таблицу плодов трудов "умельцев", которые мешают в тексте латиницу и кириллицу, написал макрос, выделяющий такие буквы разным цветом:
[vba]
Code
Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
        If TypeName(Selection) <> "Range" Then Exit Sub
        Dim iCell As Range, rRange As Range, i%, ASCII%, iColor%
        On Error GoTo eXXit
        Set rRange = Intersect(Selection, ActiveSheet.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 = 10   'цвет символов РУС
                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
eXXit:     End Sub
[/vba]
Этот макрос я у себя в Personal.xls положил, а пункт-кнопочку для его вызова в меню "Сервис" засунул с капчей "Выделить цветом РУС-LAT" и регулярно пользуюсь. Здорово помогает.



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Суббота, 29.01.2011, 22:50
 
Ответить
СообщениеДля обработки-сведения в общую учётную таблицу плодов трудов "умельцев", которые мешают в тексте латиницу и кириллицу, написал макрос, выделяющий такие буквы разным цветом:
[vba]
Code
Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
        If TypeName(Selection) <> "Range" Then Exit Sub
        Dim iCell As Range, rRange As Range, i%, ASCII%, iColor%
        On Error GoTo eXXit
        Set rRange = Intersect(Selection, ActiveSheet.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 = 10   'цвет символов РУС
                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
eXXit:     End Sub
[/vba]
Этот макрос я у себя в Personal.xls положил, а пункт-кнопочку для его вызова в меню "Сервис" засунул с капчей "Выделить цветом РУС-LAT" и регулярно пользуюсь. Здорово помогает.

Автор - Alex_ST
Дата добавления - 29.01.2011 в 22:49
Гость Дата: Среда, 11.07.2012, 10:53 | Сообщение № 2
Группа: Гости
пригодился. Спасибо!
 
Ответить
Сообщениепригодился. Спасибо!

Автор - Гость
Дата добавления - 11.07.2012 в 10:53
Alex_ST Дата: Среда, 11.07.2012, 12:28 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3099
Репутация: 581 ±
Замечаний: 0% ±

2003
Совсем забыл про этот свой пост.
А ведь вносил коррекцию: забыл про русские ё и Ё, коды которых размещены в таблице символов отдельно.
Вот так будет точнее:
[vba]
Code
Private Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
    Dim rCell As Range, i%, ASCII%, iColor%
    Application.ScreenUpdating = False
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       For i = 1 To Len(rCell)
          ASCII = Asc(Mid(rCell, i, 1))
          If (ASCII >= 192 And ASCII <= 255) Or ASCII = 168 Or ASCII = 184 Then iColor = 10   'цвет символов РУС
          If (ASCII >= 65 And ASCII <= 90) Or (ASCII >= 97 And ASCII <= 122) Then iColor = 3   'цвет символов LAT
          rCell.Characters(Start:=i, Length:=1).Font.ColorIndex = iColor
       Next i
    Next rCell
    Application.ScreenUpdating = True
    Intersect(Selection, ActiveSheet.UsedRange).Select
End Sub
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Среда, 11.07.2012, 12:29
 
Ответить
СообщениеСовсем забыл про этот свой пост.
А ведь вносил коррекцию: забыл про русские ё и Ё, коды которых размещены в таблице символов отдельно.
Вот так будет точнее:
[vba]
Code
Private Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
    Dim rCell As Range, i%, ASCII%, iColor%
    Application.ScreenUpdating = False
    For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
       For i = 1 To Len(rCell)
          ASCII = Asc(Mid(rCell, i, 1))
          If (ASCII >= 192 And ASCII <= 255) Or ASCII = 168 Or ASCII = 184 Then iColor = 10   'цвет символов РУС
          If (ASCII >= 65 And ASCII <= 90) Or (ASCII >= 97 And ASCII <= 122) Then iColor = 3   'цвет символов LAT
          rCell.Characters(Start:=i, Length:=1).Font.ColorIndex = iColor
       Next i
    Next rCell
    Application.ScreenUpdating = True
    Intersect(Selection, ActiveSheet.UsedRange).Select
End Sub
[/vba]

Автор - Alex_ST
Дата добавления - 11.07.2012 в 12:28
ikki Дата: Среда, 28.11.2012, 17:00 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1906
Репутация: 504 ±
Замечаний: 0% ±

Excel 2003, 2010
приведенные макросы всем хороши, одна беда - на больших объемах работают не слишком шустро.
у меня аналогичный макрос на 52000+ ячеек работал более 100 сек. (точнее - 102,3) на не слишком старой машине.
на первый взгляд мне казалось, что ничего глобально тут не ускоришь - цвета символов в массив быстро не заберешь и из массива на лист одной командой не выгрузишь.

но после некоторого (я понимаю - пока поверхностного) изучения RegExp'ов у меня появился такой вариант макроса, выполняющего ту же работу:

[vba]
Code
' Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub myColorRusLat()
       Dim tt&, i%, c As Range, rLat As Object, rRus As Object, x As Object
       Dim r As Range, a(), i1%, i2%, s$
'  tt = GetTickCount
       Set rLat = CreateObject("vbscript.regexp")
       With rLat
           .ignorecase = True
           .Global = True
           .Pattern = "[a-z]+"
       End With
       Set rRus = CreateObject("vbscript.regexp")
       With rRus
           .ignorecase = True
           .Global = True
           .Pattern = "[а-яё]+"
       End With
        
       Set r = Selection: a = r.Value
       For i1 = 1 To UBound(a, 1)
           For i2 = 1 To UBound(a, 2)
               If Not IsEmpty(a(i1, i2)) Then
                   s = CStr(a(i1, i2))
                   Set x = rLat.Execute(s)
                   For i = 0 To x.Count - 1
                       r(i1, i2).Characters(Start:=x(i).firstindex + 1, Length:=x(i).Length).Font.ColorIndex = 3
                   Next
                   Set x = rRus.Execute(s)
                   For i = 0 To x.Count - 1
                       r(i1, i2).Characters(Start:=x(i).firstindex + 1, Length:=x(i).Length).Font.ColorIndex = 10
                   Next
               End If
           Next
       Next
        
       Erase a: Set rLat = Nothing: Set rRus = Nothing: Set x = Nothing
'   Debug.Print GetTickCount - tt
End Sub
[/vba]

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

но моих данных этот макрос отработал за 41,8 сек. (быстрее в 2,4 раза).
думаю, разница во времени может отличаться в зависимости от того, насколько сильно "перемешаны" русские и латинские символы внутри строк, насколько длинные сами строки и т.п...

но, как вариант - можно использовать, имхо.


помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki


Сообщение отредактировал ikki - Среда, 28.11.2012, 17:07
 
Ответить
Сообщениеприведенные макросы всем хороши, одна беда - на больших объемах работают не слишком шустро.
у меня аналогичный макрос на 52000+ ячеек работал более 100 сек. (точнее - 102,3) на не слишком старой машине.
на первый взгляд мне казалось, что ничего глобально тут не ускоришь - цвета символов в массив быстро не заберешь и из массива на лист одной командой не выгрузишь.

но после некоторого (я понимаю - пока поверхностного) изучения RegExp'ов у меня появился такой вариант макроса, выполняющего ту же работу:

[vba]
Code
' Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub myColorRusLat()
       Dim tt&, i%, c As Range, rLat As Object, rRus As Object, x As Object
       Dim r As Range, a(), i1%, i2%, s$
'  tt = GetTickCount
       Set rLat = CreateObject("vbscript.regexp")
       With rLat
           .ignorecase = True
           .Global = True
           .Pattern = "[a-z]+"
       End With
       Set rRus = CreateObject("vbscript.regexp")
       With rRus
           .ignorecase = True
           .Global = True
           .Pattern = "[а-яё]+"
       End With
        
       Set r = Selection: a = r.Value
       For i1 = 1 To UBound(a, 1)
           For i2 = 1 To UBound(a, 2)
               If Not IsEmpty(a(i1, i2)) Then
                   s = CStr(a(i1, i2))
                   Set x = rLat.Execute(s)
                   For i = 0 To x.Count - 1
                       r(i1, i2).Characters(Start:=x(i).firstindex + 1, Length:=x(i).Length).Font.ColorIndex = 3
                   Next
                   Set x = rRus.Execute(s)
                   For i = 0 To x.Count - 1
                       r(i1, i2).Characters(Start:=x(i).firstindex + 1, Length:=x(i).Length).Font.ColorIndex = 10
                   Next
               End If
           Next
       Next
        
       Erase a: Set rLat = Nothing: Set rRus = Nothing: Set x = Nothing
'   Debug.Print GetTickCount - tt
End Sub
[/vba]

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

но моих данных этот макрос отработал за 41,8 сек. (быстрее в 2,4 раза).
думаю, разница во времени может отличаться в зависимости от того, насколько сильно "перемешаны" русские и латинские символы внутри строк, насколько длинные сами строки и т.п...

но, как вариант - можно использовать, имхо.

Автор - ikki
Дата добавления - 28.11.2012 в 17:00
Alex_ST Дата: Среда, 28.11.2012, 21:40 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3099
Репутация: 581 ±
Замечаний: 0% ±

2003
Саш, интересный, конечно, вариант.
Но мне, к счастью, огромных массивов данных обрабатывать не надо. Поэтому твой вариант с RegExp хоть и быстрее, но "слишкам многа букаф" biggrin (ну, в смысле код намного длиннее).
Да и не вижу я смысла раскрашивать большие массивы. Ведь раскраска нужна для быстрого визуального контроля, а как ты на огромный массив смотреть будешь?
Для больших объёмов данных нужно, наверное, что-то другое придумывать.
Ну, на вскидку (прошу не заплёвывать - идея только что пришла и я её ещё со всех сторон не рассматривал): составлять массив адресов ячеек где присутствует смесь рус-лат букв одинакового начертания и как-то просматривать только его.



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеСаш, интересный, конечно, вариант.
Но мне, к счастью, огромных массивов данных обрабатывать не надо. Поэтому твой вариант с RegExp хоть и быстрее, но "слишкам многа букаф" biggrin (ну, в смысле код намного длиннее).
Да и не вижу я смысла раскрашивать большие массивы. Ведь раскраска нужна для быстрого визуального контроля, а как ты на огромный массив смотреть будешь?
Для больших объёмов данных нужно, наверное, что-то другое придумывать.
Ну, на вскидку (прошу не заплёвывать - идея только что пришла и я её ещё со всех сторон не рассматривал): составлять массив адресов ячеек где присутствует смесь рус-лат букв одинакового начертания и как-то просматривать только его.

Автор - Alex_ST
Дата добавления - 28.11.2012 в 21:40
ikki Дата: Среда, 28.11.2012, 21:48 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1906
Репутация: 504 ±
Замечаний: 0% ±

Excel 2003, 2010
увы, я пока не могу придумать, что мне с этим делать smile
но одно применение есть - пугать ответственных за ввод данных и пилюлей отвешивать килограммами.
реально - раздам завтра свою разукрашку "по принадлежности" - снабженцам, производственникам, отделу продаж...
пусть хотя бы полюбуются на этот кошмар sad
имхо, для быстрой визуальной оценки качества данных - самое оно. wink


помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki


Сообщение отредактировал ikki - Среда, 28.11.2012, 21:51
 
Ответить
Сообщениеувы, я пока не могу придумать, что мне с этим делать smile
но одно применение есть - пугать ответственных за ввод данных и пилюлей отвешивать килограммами.
реально - раздам завтра свою разукрашку "по принадлежности" - снабженцам, производственникам, отделу продаж...
пусть хотя бы полюбуются на этот кошмар sad
имхо, для быстрой визуальной оценки качества данных - самое оно. wink

Автор - ikki
Дата добавления - 28.11.2012 в 21:48
Alex_ST Дата: Среда, 28.11.2012, 22:05 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3099
Репутация: 581 ±
Замечаний: 0% ±

2003
Ну, Саш, ради того чтобы со смаком и обоснованно раздать люлей можно и подождать немного biggrin
("Месть - это блюдо, которое подают холодным")

А вообще-то когда мне было известно, что в экспортированной из Access'a таблице должны быть только русские или только латинские буквы, я давно-давно написАл две процедурки по замене "близнецов" (принципиально для примера оставил чуть разные методы)



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеНу, Саш, ради того чтобы со смаком и обоснованно раздать люлей можно и подождать немного biggrin
("Месть - это блюдо, которое подают холодным")

А вообще-то когда мне было известно, что в экспортированной из Access'a таблице должны быть только русские или только латинские буквы, я давно-давно написАл две процедурки по замене "близнецов" (принципиально для примера оставил чуть разные методы)

Автор - Alex_ST
Дата добавления - 28.11.2012 в 22:05
ikki Дата: Среда, 28.11.2012, 22:19 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1906
Репутация: 504 ±
Замечаний: 0% ±

Excel 2003, 2010
спасибо, может пригодиться (и, конечно, не только мне).
но у меня ситуация несколько сложнее - и русские, и латинские символы могут быть.
зависит от контекста.
в основном - определяется стандартами, гостами, ту и проч.

ну, к примеру, болт по гост 7805-70
там куча букв и цифр вперемешку, часть - однозначно должны быть русские, часть - латинские.
ну ладно, перепутали...
ну уж хотя бы делайте это единообразно! smile
а то болт М6 - с русской буквой М, а соседний М5 - с латинской.
марка стали 08кп - конечно, русскими, а 40Х - с какого-то перепугу латинскими.
ну и т.п.

вот эту-то разницу как раз и видно хорошо.
а как это дело обрабатывать (точнее - перерабатывать) - буду думать...
есть пара вариантов - самому допоздна и на выходных ковыряться с регулярками для каждого варианта, или отдать "специалистам" для ручного исправления - вместе с пилюлями biggrin


помощь по Excel и VBA
ikki@fxmail.ru, icq 592842413, skype alex.ikki


Сообщение отредактировал ikki - Среда, 28.11.2012, 22:20
 
Ответить
Сообщениеспасибо, может пригодиться (и, конечно, не только мне).
но у меня ситуация несколько сложнее - и русские, и латинские символы могут быть.
зависит от контекста.
в основном - определяется стандартами, гостами, ту и проч.

ну, к примеру, болт по гост 7805-70
там куча букв и цифр вперемешку, часть - однозначно должны быть русские, часть - латинские.
ну ладно, перепутали...
ну уж хотя бы делайте это единообразно! smile
а то болт М6 - с русской буквой М, а соседний М5 - с латинской.
марка стали 08кп - конечно, русскими, а 40Х - с какого-то перепугу латинскими.
ну и т.п.

вот эту-то разницу как раз и видно хорошо.
а как это дело обрабатывать (точнее - перерабатывать) - буду думать...
есть пара вариантов - самому допоздна и на выходных ковыряться с регулярками для каждого варианта, или отдать "специалистам" для ручного исправления - вместе с пилюлями biggrin

Автор - ikki
Дата добавления - 28.11.2012 в 22:19
Alex_ST Дата: Среда, 28.11.2012, 23:28 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3099
Репутация: 581 ±
Замечаний: 0% ±

2003
Quote (ikki)
и русские, и латинские символы могут быть. зависит от контекста.

Знакомая ситуация на работе: шнур (патчкорд) оптический одномодовый (SM - Single Mode) СТАНДАРТНО в спецификациях везде обозначается на смеси рус-лат ШО SM biggrin



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
Сообщение
Quote (ikki)
и русские, и латинские символы могут быть. зависит от контекста.

Знакомая ситуация на работе: шнур (патчкорд) оптический одномодовый (SM - Single Mode) СТАНДАРТНО в спецификациях везде обозначается на смеси рус-лат ШО SM biggrin

Автор - Alex_ST
Дата добавления - 28.11.2012 в 23:28
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "Color_RUS_LAT" (Выделяет РУС-символы в Selection ЗЕЛЁНЫМ, а LAT - КРАСНЫМ)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2020 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!