'Автоматическая конвертация всех символов в тексте с русских на английские

'Автоматическая конвертация всех символов в тексте с русских на английские
Sub autoConvertRuToEng()
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sRus - это русские символы которые нужно менять. sLat - это английские символы, которые нужно подставить вместо русских)
sRus = Array("й", "ц", "у", "к", "е", "н", "г", "ш", "щ", "з", "х", "ъ", "ф", "ы", "в", "а", "п", "р", "о", "л", "д", "ж", "э", "я", "ч", "с", "м", "и", "т", "ь", "б", "ю", ".", "ё", "№", ";", "?", "Б", "Ю", ",", _
"Й", "Ц", "У", "К", "Е", "Н", "Г", "Ш", "Щ", "З", "Х", "Ъ", "Ф", "Ы", "В", "А", "П", "Р", "О", "Л", "Д", "Ж", "Э", "Я", "Ч", "С", "М", "И", "Т", "Ь", "Ё", Chr(34))
sLat = Array("q", "w", "e", "r", "t", "y", "u", "i", "o", "p", "[", "]", "a", "s", "d", "f", "g", "h", "j", "k", "l", ";", "'", "z", "x", "c", "v", "b", "n", "m", ",", ".", "/", "`", "#", "$", "&", "<", ">", "?", _
"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P", "{", "}", "A", "S", "D", "F", "G", "H", "J", "K", "L", ":", Chr(34), "Z", "X", "C", "V", "B", "N", "M", "~", "@")
Application.ScreenUpdating = False 'Запрещаем обновление экрана во время работы макроса
With rDoc.Find
'заменяем все русские символы на соответствующие английские
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False
.Format = True
.MatchCase = True
For i = LBound(sRus) To UBound(sLat)
.Text = sRus(i)
.Replacement.Text = sLat(i)
.Execute Replace:=wdReplaceAll
Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

Макрос замены английских букв на русские во всём тексте

'Автоматическая конвертация всех символов в тексте с английских на русские
Sub autoConvertEngToRu()
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sLat - это английские символы которые нужно менять. sRus - это русские символы, которые подставляются вместо английских)
sLat = Array("q", "w", "e", "r", "t", "y", "u", "i", "o", "p", "[", "]", "a", "s", "d", "f", "g", "h", "j", "k", "l", ";", "'", "z", "x", "c", "v", "b", "n", "m", ",", ".", "/", "`", "#", "$", "^", "&", "<", ">", "?", "№", _
"Q", "W", "E", "R", "T", "Y", "U", "I", "O", "P", "{", "}", "A", "S", "D", "F", "G", "H", "J", "K", "L", ":", Chr(34), "Z", "X", "C", "V", "B", "N", "M", "~", "@")
sRus = Array("й", "ц", "у", "к", "е", "н", "г", "ш", "щ", "з", "х", "ъ", "ф", "ы", "в", "а", "п", "р", "о", "л", "д", "ж", "э", "я", "ч", "с", "м", "и", "т", "ь", "б", "ю", ".", "ё", "№", ";", ":", "?", "Б", "Ю", ",", "#", _
"Й", "Ц", "У", "К", "Е", "Н", "Г", "Ш", "Щ", "З", "Х", "Ъ", "Ф", "Ы", "В", "А", "П", "Р", "О", "Л", "Д", "Ж", "Э", "Я", "Ч", "С", "М", "И", "Т", "Ь", "Ё", Chr(34))
Application.ScreenUpdating = False 'Запрещаем обновление экрана во время работы макроса
With rDoc.Find
'заменяем все английские символы на соответствующие русские
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False
.Format = True
.MatchCase = True
For i = LBound(sLat) To UBound(sRus)
.Text = sLat(i)
.Replacement.Text = sRus(i)
.Execute Replace:=wdReplaceAll
Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub