Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As LongDim KeybLayoutName As String
 
Const HOOKED_KEYS As String = "f,dult`;pbqrkvyjghcnea[wxio]sm'.z 0123456789@-_\/"
 
Function InRange(Target As range, RangeIn As range) As Boolean
    InRange = Not Intersect(Target, RangeIn) Is Nothing
End Function
 
Function CaseRanges(strkey As String) As String
    If (InRange(ActiveCell, range("A32:AP34"))) Then
        CaseRanges = strkey
        Exit Function
    End If
    If (InRange(ActiveCell, range("38:46, 55:66")) And strkey <> " ") Then
        CaseRanges = "X"
        Exit Function
    End If
    CaseRanges = UCase(strkey)
End Function
 
Function ChangeLang(strkey As String) As String
    Const KEYB_RUS As String = "00000419"
    Const KEYB_ENG As String = "00000409"
    Dim CharsRus As String, CharsEng As String
    CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z"
    
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    
    Dim i As Integer
    Dim LangRus As Boolean
    LangRus = (StrComp(KeybLayoutName, KEYB_RUS, vbTextCompare) = 0)
    If LangRus Then
        i = InStr(CharsEng, strkey)
    Else
        i = InStr(CharsRus, strkey)
    End If
    If i = 0 Then
        ChangeLang = strkey
        Exit Function
    End If
    If LangRus Then
        ChangeLang = Mid(CharsRus, i, 1)
    Else
        ChangeLang = Mid(CharsEng, i, 1)
    End If
End Function
 
Sub CellEnterFinish(keycode As Integer)
'    On Error Resume Next
   strkey = CaseRanges(ChangeLang(Chr(keycode)))
    If Not ActiveCell.AllowEdit Then ActiveCell.Next.Activate
    ActiveCell.Value = strkey
    ActiveCell.Next.Activate
End Sub
 
Sub HookKeys(Str As String, FuncName As String)
'   On Error Resume Next
   For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}", "'" & FuncName & """" & Asc(s) & """'"
        Else
            sx = CInt(s) + 96
            Application.OnKey s, "'" & FuncName & """" & Asc(s) & """'"
            Application.OnKey "{" & sx & "}", "'" & FuncName & """" & Asc(s) & """'"
        End If
    Next
End Sub
 
Sub UnHookKeys(Str As String)
'    On Error Resume Next
   For i = 1 To Len(Str)
        s = Mid(Str, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}"
        Else
            sx = CInt(s) + 96
            Application.OnKey s
            Application.OnKey "{" & sx & "}"
        End If
    Next
End Sub
 
Private Sub RemovePrev()
'    On Error Resume Next
   If ActiveCell.Value <> "" And ActiveCell.Value <> " " Then
        ActiveCell.Value = ""
        Exit Sub
    End If
    ActiveCell.Previous.Activate
    ActiveCell.Value = ""
End Sub
 
Sub НВР_ХРУЩ_ОднаБукваВКаждойЯчейке()
'    On Error Resume Next
   HookKeys HOOKED_KEYS, "CellEnterFinish"
    Application.OnKey "{BACKSPACE}", "RemovePrev"
    Application.OnKey "{TAB}"
End Sub
 
Private Sub Auto_Close()
    UnHookKeys HOOKED_KEYS
    Application.OnKey "{BACKSPACE}"
End Sub