Sub changeLang() 'переключение с английской раскладки на русскую и наоборот
    Dim i%, j%, str1$, str2$, strout$
    Dim rng As Range, cell As Range
    Dim da As Boolean
       
    Dim Rus As Variant
    Rus = Array("а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", _
        "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", _
        "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", "Д", "Е", "Ё", _
        "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", "С", "Т", "У", _
        "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я", ".", ",", _
        "?", ":", ";", "№", """", "f", ",", "d", "u", "l", "t", "`", ";", "p", _
        "b", "q", "r", "k", "v", "y", "j", "g", "h", "c", "n", "e", "a", "[", _
        "w", "x", "i", "o", "]", "s", "m", "'", ".", "z", "F", "<", "D", "U", _
        "L", "T", "~", ":", "P", "B", "Q", "R", "K", "V", "Y", "J", "G", "H", _
        "C", "N", "E", "A", "{", "W", "X", "I", "O", "}", "S", "M", """", ">", _
        "Z", "/", "?", "&", "^", "$", "#", "@")
        
    Dim Eng As Variant
    Eng = Array("f", ",", "d", "u", "l", "t", "`", ";", "p", "b", "q", "r", _
        "k", "v", "y", "j", "g", "h", "c", "n", "e", "a", "[", "w", "x", "i", _
        "o", "]", "s", "m", "'", ".", "z", "F", "<", "D", "U", "L", "T", "~", _
        ":", "P", "B", "Q", "R", "K", "V", "Y", "J", "G", "H", "C", "N", "E", _
        "A", "{", "W", "X", "I", "O", "}", "S", "M", """", ">", "Z", "/", "?", _
        "&", "^", "$", "#", "@", "а", "б", "в", "г", "д", "е", "ё", "ж", "з", _
        "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", _
        "ц", "ч", "ш", "щ", "ъ", "ы", "ь", "э", "ю", "я", "А", "Б", "В", "Г", _
        "Д", "Е", "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", _
        "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", _
        "Я", ".", ",", "?", ":", ";", "№", """")
      
    On Error Resume Next
    
    If Selection.Cells.Count > 1 And Not ActiveCell.MergeCells Then
        Set rng = Selection.SpecialCells(xlCellTypeConstants)
    Else
        Set rng = Selection
    End If
    
    On Error GoTo 0
    
    For Each cell In rng
        If (Not IsEmpty(cell)) And (Not IsError(cell)) Then
            strout = ""
            For i = 1 To Len(cell)
                str1 = Mid(cell, i, 1)
                da = False
                For j = 0 To 144
                    If Eng(j) = str1 Then
                        str2 = Rus(j)
                        da = True
                        Exit For
                    End If
                Next j
                If da Then strout = strout & str2 Else strout = strout & _
                    str1
            Next i
            cell.Value = strout
        End If
    Next cell
End Sub