Перемещение на несколько столбцов одним нажатием

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type MSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
 
Private Declare Function WaitMessage Lib "user32" () As Long
 
Private Declare Function PeekMessage Lib "user32" _
Alias "PeekMessageA" _
(ByRef lpMsg As MSG, ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long
 
Private Declare Function TranslateMessage Lib "user32" _
(ByRef lpMsg As MSG) As Long
 
Private Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Const WM_KEYDOWN As Long = &H100
Private Const PM_REMOVE  As Long = &H1
Private Const WM_CHAR    As Long = &H102
Private bExitLoop As Boolean
 
Private Const LeftKey As Long = 37
Private Const UpKey As Long = 38
Private Const RightKey As Long = 39
Private Const DownKey As Long = 40
 
Private Const LeftOffset As Long = 3
Private Const UpOffset As Long = 2
Private Const RightOffset As Long = 5
Private Const DownOffset As Long = 4
 
Sub StartKeyWatch()
 
    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long
 
    On Error GoTo handleCancel:
    Application.EnableCancelKey = xlErrorHandler
    bExitLoop = False
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    Do
        WaitMessage
        If PeekMessage(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            iKeyCode = msgMessage.wParam
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, WM_CHAR, PM_REMOVE
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
            bCancel = True
            Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
            If bCancel = False Then
                PostMessage lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
            End If
        End If
        DoEvents
    Loop Until bExitLoop
    
handleCancel:
If Err = 18 Then
    bExitLoop = True
End If
 
End Sub
 
Private Sub Sheet_KeyPress _
(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, _
ByVal Target As Range, Cancel As Boolean)
 
    Select Case KeyAscii
    Case LeftKey
        If ActiveCell.Column > LeftOffset Then
            ActiveCell.Offset(0, -LeftOffset).Activate
        End If
    Case UpKey
        If ActiveCell.Row > UpOffset Then
            ActiveCell.Offset(-UpOffset, 0).Activate
        End If
    Case RightKey
        ActiveCell.Offset(0, RightOffset).Activate
    Case DownKey
        ActiveCell.Offset(DownOffset, 0).Activate
    Case Else
        Cancel = False
    End Select
 
End Sub