Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim KeybLayoutName As String

Const HOOKED_KEYS As String = "f,dult`;pbqrkvyjghcnea[wxio]sm'.z 0123456789@-_\/" 'Lib "fedorov" GetKeyboardLayoutNameA
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
If LangRus And strkey = "/" Then
ChangeLang = "."
Else
ChangeLang = strkey
End If
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 String)

On Error Resume Next
Dim shift As Boolean
shift = Left(keycode, 1) = "s" ' для поддержки заглавных букв в таких полях, как email, skype и т.п.
If shift Then keycode = Mid(keycode, 2)
strkey = CaseRanges(ChangeLang(Chr(keycode)))
If shift Then strkey = UCase(strkey)
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) & """'"
If Not InStr("!@#$%^&*()_+~|", s) Then
Application.OnKey "+{" & s & "}", "'" & FuncName & """s" & Asc(s) & """'"
End If
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

Private Sub GoToNextField()

Dim next_cell_x As Integer
next_cell_x = ActiveCell.Column + 1
While ActiveCell.Column + 1 = next_cell_x
ActiveCell.Next.Activate
next_cell_x = next_cell_x + 1
Wend
End Sub

Sub НВР_ХРУЩ_ОднаБукваВКаждойЯчейке()

On Error Resume Next
HookKeys HOOKED_KEYS, "CellEnterFinish"
Application.OnKey "{BACKSPACE}", "RemovePrev"
Application.OnKey "{ENTER}", "GoToNextField"
Application.OnKey "~", "GoToNextField"
Application.OnKey "{TAB}"
End Sub

Private Sub Auto_Close()

UnHookKeys HOOKED_KEYS
Application.OnKey "{BACKSPACE}"
Application.OnKey "{ENTER}"
Application.OnKey "~"
End Sub

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

Sub FilePrintDuplex()
ActiveDocument.PrintOut ManualDuplexPrint:=True
End Sub