: VBA Вопросы и Ответы (Готовые решения); 24 июля 2022; Просмотров: 1162

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

Представляю вашему вниманию набор макросов для смены раскладки клавиатуры на тот случай, если вы напечатаете текст не теми буквами.

Используя эти макросы и сделав всего лишь несколько кликов, вы сможете:

Заменить английские буквы на русские во всём тексте
Заменить английские буквы на украинские во всём тексте
Заменить русские буквы на английские во всём тексте
Заменить русские буквы на украинские во всём тексте
Заменить украинские буквы на английские во всём тексте
Заменить украинские буквы на русские во всём тексте
Заменить английские буквы на русские в выделенном фрагменте текста
Заменить английские буквы на украинские в выделенном фрагменте текста
Заменить русские буквы на английские в выделенном фрагменте текста
Заменить русские буквы на украинские в выделенном фрагменте текста
Заменить украинские буквы на английские в выделенном фрагменте текста
Заменить украинские буквы на русские в выделенном фрагменте текста

Пояснение кода

Первые примеры кода выполняют полную проверку всего текста и меняют в нём все символы на те, которые нужно. Для того чтобы выполнить замену символов только в выделенном фрагменте тексте, достаточно заменить одну строку:

Set rDoc=ActiveDocument.Range на Set rDoc=Selection.Range

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

'Автоматическая конвертация всех символов в тексте с английских на русские
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

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

'Автоматическая конвертация всех символов в тексте с английских на украинские
Sub autoConvertEngToUa()
Dim i As Integer
Dim sLat As Variant
Dim sUa As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sLat - это английские символы которые нужно менять. sUa - это украинские символы, которые подставляются вместо английских)
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", "~", "@")
sUa = 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(sUa)
      .Text = sLat(i)
      .Replacement.Text = sUa(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Автоматическая конвертация всех символов в тексте с русских на английские
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 autoConvertRuToUa()
Dim i As Integer
Dim sUa As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sRus - это русские символы которые нужно менять. sUa - это украинские символы, которые подставляются вместо русских)
sRus = Array("ё", "ъ", "ы", "э", "Ё", "Ъ", "Ы", "Э")
sUa = Array("'", "ї", "і", "є", "?", "Ї", "І", "Є")
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(sUa)
      .Text = sRus(i)
      .Replacement.Text = sUa(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Автоматическая конвертация всех символов в тексте с украинских на английские
Sub autoConvertUaToEng()
Dim i As Integer
Dim sLat As Variant
Dim sUa As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sUa - это украинские символы которые нужно менять. sLat - это английские символы, которые нужно подставить вместо украинских)
sUa = 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(sUa) To UBound(sLat)
      .Text = sUa(i)
      .Replacement.Text = sLat(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Автоматическая конвертация всех символов в тексте с украинских на русские
Sub autoConvertUaToRu()
Dim i As Integer
Dim sUa As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = ActiveDocument.Range
'Список букв которые нужно менять (sUa - это украинские символы которые нужно менять. sRus - это русские символы, которые подставляются вместо украинских)
sUa = Array("'", "ї", "і", "є", "?", "Ї", "І", "Є")
sRus = Array("ё", "ъ", "ы", "э", "Ё", "Ъ", "Ы", "Э")
Application.ScreenUpdating = False 'Запрещаем обновление экрана во время работы макроса
With rDoc.Find
'заменяем все украинские символы на соответствующие русские
   .ClearFormatting
   .Replacement.ClearFormatting
   .Forward = True
   .Wrap = wdFindStop
   .MatchWildcards = False
   .Format = True
   .MatchCase = True
   For i = LBound(sUa) To UBound(sRus)
      .Text = sUa(i)
      .Replacement.Text = sRus(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Конвертация выделенных символов в тексте с английских на русские
Sub convertEngToRu()
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Selection.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

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

'Конвертация выделенных символов в тексте с английских на украинские
Sub convertEngToUa()
Dim i As Integer
Dim sLat As Variant
Dim sUa As Variant
Dim rDoc As Range
Set rDoc = Selection.Range
'Список букв которые нужно менять (sLat - это английские символы которые нужно менять. sUa - это украинские символы, которые подставляются вместо английских)
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", "~", "@")
sUa = 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(sUa)
      .Text = sLat(i)
      .Replacement.Text = sUa(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Конвертация выделенных символов в тексте с русских на английские
Sub convertRuToEng()
Dim i As Integer
Dim sLat As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Selection.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 convertRuToUa()
Dim i As Integer
Dim sUa As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Selection.Range
'Список букв которые нужно менять (sRus - это русские символы которые нужно менять. sUa - это украинские символы, которые подставляются вместо русских)
sRus = Array("ё", "ъ", "ы", "э", "Ё", "Ъ", "Ы", "Э")
sUa = Array("'", "ї", "і", "є", "?", "Ї", "І", "Є")
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(sUa)
      .Text = sRus(i)
      .Replacement.Text = sUa(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Конвертация выделенных символов в тексте с русских на английские
Sub convertUaToEng()
Dim i As Integer
Dim sLat As Variant
Dim sUa As Variant
Dim rDoc As Range
Set rDoc = Selection.Range
'Список букв которые нужно менять (sUa - это украинские символы которые нужно менять. sLat - это английские символы, которые нужно подставить вместо украинских)
sUa = 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(sUa) To UBound(sLat)
      .Text = sUa(i)
      .Replacement.Text = sLat(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub

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

'Конвертация выделенных символов в тексте с украинских на русские
Sub convertUaToRu()
Dim i As Integer
Dim sUa As Variant
Dim sRus As Variant
Dim rDoc As Range
Set rDoc = Selection.Range
'Список букв которые нужно менять (sUa - это украинские символы которые нужно менять. sRus - это русские символы, которые подставляются вместо украинских)
sUa = Array("'", "ї", "і", "є", "?", "Ї", "І", "Є")
sRus = Array("ё", "ъ", "ы", "э", "Ё", "Ъ", "Ы", "Э")
Application.ScreenUpdating = False 'Запрещаем обновление экрана во время работы макроса
With rDoc.Find
'заменяем все украинские символы на соответствующие русские
   .ClearFormatting
   .Replacement.ClearFormatting
   .Forward = True
   .Wrap = wdFindStop
   .MatchWildcards = False
   .Format = True
   .MatchCase = True
   For i = LBound(sUa) To UBound(sRus)
      .Text = sUa(i)
      .Replacement.Text = sRus(i)
      .Execute Replace:=wdReplaceAll
   Next i
End With
Application.ScreenUpdating = True 'Обновляем экран
End Sub