Спасибо Alex_ST за вариант покороче и поизящнее. Жаль что не встречал этого решения раньше :-). Первый пример с поиском и выделением работает. Макрос с Заменой не работает Просьба подправить
надо менять алгоритмы в коде движка. Ну очень неудобно редактировать опубликованное и просматривать перед публикацией текст в теге {CODE} Слетает всё форматирование кода
Можно прилепить проверку диапазона выделения и если например выделен весь столбец, то перевыделить до конца данных
Код
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
так получается гораздо быстрее отрабатывает макрос
Понадобились коллегам такие вот функции в 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
Предложения по улучшению кода приветствуются :-)
!!! после нажатия на `просмотр` форматирование в коде слетает (видно задействуется функция которая убирает лишние пробелы-символы в коде форума) Поправить бы надо, а то неудобно очень :-)