Понадобились коллегам такие вот функции в 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
Предложения по улучшению кода приветствуются :-)
!!! после нажатия на `просмотр` форматирование в коде слетает (видно задействуется функция которая убирает лишние пробелы-символы в коде форума) Поправить бы надо, а то неудобно очень :-)
Можно прилепить проверку диапазона выделения и если например выделен весь столбец, то перевыделить до конца данных
Код
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
так получается гораздо быстрее отрабатывает макрос
надо менять алгоритмы в коде движка. Ну очень неудобно редактировать опубликованное и просматривать перед публикацией текст в теге {CODE} Слетает всё форматирование кода
ОФФТОП: а что, теперь в "Копилку" не администрация сама кладёт "лучшие куски" как было на старой Планете, а каждый сам волен? Это я к тому, что процедура, приведённая Евгением, в разных вариантах уже выкладывалась разными авторами. И решения, кажется, были поизящнее и покороче.
С уважением, Алексей(ИМХО: 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 за вариант покороче и поизящнее. Жаль что не встречал этого решения раньше :-). Первый пример с поиском и выделением работает. Макрос с Заменой не работает Просьба подправить
Ну да, конечно... Позор на мою седую бороду :o Хотел для демонстрации использовать два разных способа и второй не проверил (в Split без указания Delimiter'a вместо пробелов поставил запятые, да и переменные не правильно задал к тому же ) Исправил и проверил - работает:
Код
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!!!)