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