Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Поиск и выделение + замена киррилических букв схожих с английскими
 
Понадобились коллегам такие вот функции в EXEL. Есть альтернатива с поиском проще, но вот по замене не встречал такой. Переделать под замену лат на рус проще простого.
Все работает :-)
Это поиск :

Код
Sub find_Rus() 'Поиск и выделение в выделенном диапазоне киррилических букв схожих с англицкими
Dim i As Integer
Dim s As Integer
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Application.Selection()
Dim iCell As Range
'список русских букв
sRus = Array("е", "у", "и", "о", "р", "а", "к", "х", "с", _
"Е", "Т", "О", "Р", "А", "Н", "К", "Х", "С", "В", "М")
Application.ScreenUpdating = False  ' Запрещаем обновление экрана во время работы макроса

For i = LBound(sRus) To UBound(sRus)
Set iCell = rDoc.Find(What:=sRus(i), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True)
 
  If Not iCell Is Nothing Then
       iAddress$ = iCell.Address
          Do
            If Not iCell.HasFormula Then
               iPosition% = InStr(iCell.Value, sRus(i))
                 Do
                   iCell.Characters(Start:=iPosition, Length:=Len(sRus(i))).Font.Bold = True
                   iCell.Characters(Start:=iPosition, Length:=Len(sRus(i))).Font.Color = vbRed
                   iPosition% = InStr(iPosition% + 1, iCell.Value, sRus(i))
                   s = s + 1
                 Loop While iPosition% <> 0
            End If
            Set iCell = rDoc.FindNext(After:=iCell)
          Loop While iCell.Address <> iAddress$
  End If
Next i
Application.ScreenUpdating = True  ' Обновляем экран
MsgBox "Найдено " & s & " совпадений"
End Sub

------------------------------------------------------------------------------

Это замена :

Код
Sub changeRusToLat() 'Замена в выделенном диапазоне киррилических букв на латинские
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Application.Selection()
'список русских букв
sRus = Array("в", "е", "у", "и", "о", "р", "а", "к", "х", "с", _
"Е", "Т", "О", "Р", "А", "Н", "К", "Х", "С", "В", "М")
'список латинских букв
sLat = Array("b", "e", "y", "u", "o", "p", "a", "k", "x", "c", _
"E", "T", "O", "P", "A", "H", "K", "X", "C", "B", "M")

Application.ScreenUpdating = False  ' Запрещаем обновление экрана во время работы макроса
For i = LBound(sRus) To UBound(sRus)
rDoc.Replace What:=sRus(i), Replacement:=sLat(i), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, ReplaceFormat:=False
Next i
With rDoc.Characters.Font
.ColorIndex = 1
.FontStyle = Normal
End With
Application.ScreenUpdating = True  ' Обновляем экран
MsgBox "Замена Выполнена", vbInformation
End Sub


Предложения по улучшению кода приветствуются :-)



!!! после нажатия на `просмотр` форматирование в коде слетает
(видно задействуется функция которая убирает лишние пробелы-символы в коде форума)
Поправить бы надо, а то неудобно очень :-)
Изменено: Евгений - 10 Янв 2013 10:04:39
 
форматируйте код заново  :)
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
Лучше всего прикрепить его в Txt-файле.
 
Можно прилепить проверку диапазона выделения и если например выделен весь столбец, то перевыделить до конца данных
Код
Sub find_Rus() 'Поиск и выделение в выделенном диапазоне киррилических букв схожих с англицкими
Dim i As Integer
Dim s As Integer
Dim sRus As Variant
Dim rDoc As Range
Dim iSelectionAddress As String
Set rDoc = Application.Selection()
Dim iCell As Range
'список русских букв
sRus = Array("е", "у", "и", "о", "р", "а", "к", "х", "с", _
"Е", "Т", "О", "Р", "А", "Н", "К", "Х", "С", "В", "М")
Application.ScreenUpdating = False  ' Запрещаем обновление экрана во время работы макроса
iSelectionAddress = rDoc.Address ' адрес выделения

iSelectionAddressLen$ = Len(iSelectionAddress) ' длина адресной строки
If iSelectionAddressLen = 5 Then ' значит выделен столб до бесконечность
iColumn$ = Mid(iSelectionAddress, 2, 1) ' буква столбца из адреса
i = Cells(Rows.Count, iColumn).End(xlUp).Row ' последняя заполненная строка в столбце
iAddress$ = Mid(iSelectionAddress, 1, 2) & 1 & Mid(iSelectionAddress, 3) & i 'составляем нормальный адрес до конца колонки данных
Range(iAddress).Select ' выделяем новый диапазон
Set rDoc = Application.Selection()
End If
For i = LBound(sRus) To UBound(sRus)
Set iCell = rDoc.Find(What:=sRus(i), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True)
 
  If Not iCell Is Nothing Then
            jAddress$ = iCell.Address
             Do
              If Not iCell.HasFormula Then
                iPosition% = InStr(iCell.Value, sRus(i))
                  Do
                     iCell.Characters(Start:=iPosition, Length:=Len(sRus(i))).Font.Bold = True
                     iCell.Characters(Start:=iPosition, Length:=Len(sRus(i))).Font.Color = vbRed
                     iPosition% = InStr(iPosition% + 1, iCell.Value, sRus(i))
                     s = s + 1
                  Loop While iPosition% <> 0
                End If
               Set iCell = rDoc.FindNext(After:=iCell)
            Loop While iCell.Address <> jAddress$
   End If
Next i
Application.ScreenUpdating = True  ' Обновляем экран
MsgBox "Найдено " & s & " совпадений"
End Sub


Так же и с макросом замены

Код
Sub changeRusToLat() 'Замена в выделенном диапазоне киррилических букв на латинские
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Dim iSelectionAddress As String
Set rDoc = Application.Selection()
'список русских букв
sRus = Array("в", "е", "у", "и", "о", "р", "а", "к", "х", "с", _
"Е", "Т", "О", "Р", "А", "Н", "К", "Х", "С", "В", "М")
'список латинских букв
sLat = Array("b", "e", "y", "u", "o", "p", "a", "k", "x", "c", _
"E", "T", "O", "P", "A", "H", "K", "X", "C", "B", "M")

iSelectionAddress = rDoc.Address ' адрес выделения

iSelectionAddressLen$ = Len(iSelectionAddress) ' длина адресной строки
If iSelectionAddressLen = 5 Then ' значит выделен столб до бесконечность
iColumn$ = Mid(iSelectionAddress, 2, 1) ' буква столбца из адреса
i = Cells(Rows.Count, iColumn).End(xlUp).Row ' последняя заполненная строка в столбце
iAddress$ = Mid(iSelectionAddress, 1, 2) & 1 & Mid(iSelectionAddress, 3) & i 'составляем нормальный адрес до конца колонки данных
Range(iAddress).Select ' выделяем новый диапазон
Set rDoc = Application.Selection()
End If
Application.ScreenUpdating = False  ' Запрещаем обновление экрана во время работы макроса
For i = LBound(sRus) To UBound(sRus)
rDoc.Replace What:=sRus(i), Replacement:=sLat(i), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, ReplaceFormat:=False
Next i
With rDoc.Characters.Font
.ColorIndex = 1
.FontStyle = Normal
End With
Application.ScreenUpdating = True  ' Обновляем экран
MsgBox "Замена Выполнена", vbInformation
End Sub


так получается гораздо быстрее отрабатывает макрос
Изменено: Евгений - 10 Янв 2013 15:25:18
 
надо менять алгоритмы в коде движка. Ну очень неудобно редактировать опубликованное  и просматривать перед публикацией текст в теге  {CODE}
Слетает всё форматирование кода  :(
 
Пока не исправили ситуацию с тегами-кодами, лучше редактировать не в своём сообщении, а в самом редакторе. Затем вставить целиком новый код.
 
ОФФТОП: а что, теперь в "Копилку" не администрация сама кладёт "лучшие куски" как было на старой Планете, а каждый сам волен?
Это я к тому, что процедура, приведённая Евгением, в разных вариантах уже выкладывалась разными авторами. И решения, кажется, были поизящнее и покороче.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Да,- пока "Копилка" открыта для всех Я тоже считаю, что это неправильно.
 
Ну так модерируй!
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Да нет особого повода :-)
 
Ну, раз в "Копилке" можно и самим выкладывать, то я не поленился, порылся в своих заначках по поиску и выделению РУС-ЛАТ.
Всё, действительно, намного короче можно сделать.
Вот так делается поиск и выделение:
Код
Sub Color_RUS_LAT()   ' выделить русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Dim rCell As Range, i%, iColor%, ch$
      With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
      For Each rCell In Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants))
         For i = 1 To Len(rCell)
            ch = LCase(Mid(rCell, i, 1))
            iColor = IIf(ch Like "[а-яё]", 10, IIf(ch Like "[a-z]", 3, xlColorIndexAutomatic))   ' 10 - цвет символов РУС, 3 - цвет символов LAT
            rCell.Characters(i, 1).Font.ColorIndex = iColor
         Next i
      Next rCell
      With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
   End With
End Sub

А так - восстановление текста после работы тех, кому лень РУС-ЛАТ переключать:
Код
Sub Repair_RUS()   ' заменить латинские буквы такими же по начертанию русскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Dim LATChr$: LATChr = "CcEeTOopPAaHKkXxBM"
      Dim RUSChr$: RUSChr = "СсЕеТОорРАаНКкХхВМ"
      Dim i%
      For i = 1 To Len(LATChr)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=Mid(LATChr, i, 1), Replacement:=Mid(RUSChr, i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
End Sub

Sub Repair_LAT()   ' заменить русские буквы такими же по начертанию латинскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Dim arrENG(): arrENG = Split("C,c,E,e,T,O,o,p,P,A,a,H,K,k,X,x,B,M")
      Dim arrRUS(): arrRUS = Split("С,с,Е,е,Т,О,о,р,Р,А,а,Н,К,к,Х,х,В,М")
      Dim i%
      For i = 0 To UBound(arrENG)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=arrRUS(i), Replacement:=arrENG(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Спасибо Alex_ST за вариант покороче и поизящнее. Жаль что не встречал этого решения раньше :-).
Первый пример с поиском и выделением работает.
Макрос с Заменой не работает
Просьба подправить
Изменено: Евгений - 16 Янв 2013 09:28:52
 
Ну да, конечно...
Позор на мою седую бороду :o
Хотел для демонстрации использовать два разных способа и второй не проверил (в Split без указания Delimiter'a вместо пробелов поставил запятые, да и переменные не правильно задал к тому же :oops: )
Исправил и проверил - работает:
Код
Sub Repair_RUS()   ' заменить латинские буквы такими же по начертанию русскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim LATChr$: LATChr = "CcEeTOopPAaHKkXxBM"
      Dim RUSChr$: RUSChr = "СсЕеТОорРАаНКкХхВМ"
      Dim i%
      For i = 1 To Len(LATChr)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=Mid(LATChr, i, 1), Replacement:=Mid(RUSChr, i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Sub Repair_LAT()   ' заменить русские буквы такими же по начертанию латинскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim arrENG: arrENG = Split("C c E e T O o p P A a H K k X x B M")
      Dim arrRUS: arrRUS = Split("С с Е е Т О о р Р А а Н К к Х х В М")
      Dim i%
      For i = 0 To UBound(arrENG)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=arrRUS(i), Replacement:=arrENG(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
Страницы: 1
Читают тему (гостей: 1)