编辑单元格时按键是否会触发任何事件？

Is it in any way possible to capture events as you press a key in (make an edit to) a specific cell in a worksheet?

当您按下（编辑）工作表中的特定单元格时，以任何方式捕获事件是否可行？

The closest one is know is the Change Event but that can only be activated as soon the edited cell is deselected. I want to capture the event while I'm editing the cell.

最接近的是知道变更事件，但只有在取消选择已编辑的单元格后才能激活。我想在编辑单元格时捕获事件。

3 个解决方案

#1

Here is the answer, I have tested the same and it is working properly for me.

这是答案，我已经测试了同样的，它对我来说正常。

Track the Keypress in Excel

在Excel中跟踪Keypress

Interesting Question: MS Excel's Worksheet_Change event always fired, when you are done with your changes and getting out of the cell. To trap the Key Press event. Tracking of Keypress event is not possible with excel standard or built-in functions.

有趣的问题：当您完成更改并离开单元格时，MS Excel的Worksheet_Change事件始终会被触发。捕获Key Press事件。使用excel标准或内置函数无法跟踪Keypress事件。

This can be achieved by using the API.

这可以通过使用API​​来实现。

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

Sub TrackKeyPressInit()

    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long

    On Error GoTo errHandler:
        Application.EnableCancelKey = xlErrorHandler
        'initialize this boolean flag.
        bExitLoop = False
        'get the app hwnd.
        lXLhwnd = FindWindow("XLMAIN", Application.Caption)
    Do
        WaitMessage
        'check for a key press and remove it from the msg queue.
        If PeekMessage _
            (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            'strore the virtual key code for later use.
            iKeyCode = msgMessage.wParam
           'translate the virtual key code into a char msg.
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
            WM_CHAR, PM_REMOVE
           'for some obscure reason, the following
          'keys are not trapped inside the event handler
            'so we handle them here.
            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
           'assume the cancel argument is False.
            bCancel = False
            'the VBA RaiseEvent statement does not seem to return ByRef arguments
            'so we call a KeyPress routine rather than a propper event handler.
            Sheet_KeyPress _
            ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
            'if the key pressed is allowed post it to the application.
            If bCancel = False Then
                PostMessage _
                lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
            End If
        End If
errHandler:
        'allow the processing of other msgs.
        DoEvents
    Loop Until bExitLoop

End Sub

Sub StopKeyWatch()

    'set this boolean flag to exit the above loop.
    bExitLoop = True

End Sub


'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\characters in the Range "A1:D10" .
Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, _
                           ByVal KeyCode As Integer, _
                           ByVal Target As Range, _
                           Cancel As Boolean)

    Const MSG As String = _
    "Numeric Characters are not allowed in" & _
    vbNewLine & "the Range:  """
    Const TITLE As String = "Invalid Entry !"

    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If Chr(KeyAscii) Like "[0-9]" Then
            MsgBox MSG & Range("A1:D10").Address(False, False) _
            & """ .", vbCritical, TITLE
            Cancel = True
        End If
    End If

End Sub

#2

I know this is an old question, but I recently needed similar functionality and the provided answer had some limitations that I had to address with how it handled (or didn't handle) the Del, Backspace, Function Keys, etc.

我知道这是一个老问题，但我最近需要类似的功能，并且提供的答案有一些限制，我必须解决它如何处理（或不处理）Del，Backspace，Function Keys等。

The fix is to post back back the original message instead of the translated one.

修复是回发原始邮件而不是翻译的邮件。

Also changed to use a Class Module with Events since it works fine in Excel 2010 and I didn't want to copy the same code to multiple sheets:

也改为使用带有事件的类模块，因为它在Excel 2010中工作正常，我不想将相同的代码复制到多个工作表：

Class Module

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

Public Event KeyPressed
    (ByVal KeyAscii As Integer, _
     ByVal KeyCode As Integer, _
     ByVal Target As Range, _
     ByRef Cancel As Boolean)

Public Sub StartKeyPressInit()
    Dim msgMessage As MSG
    Dim bCancel As Boolean
    Dim iMessage As Integer
    Dim iKeyCode As Integer
    Dim lXLhwnd As Long

    On Error GoTo errHandler
    Application.EnableCancelKey = xlErrorHandler
    'Initialize this boolean flag.
    bExitLoop = False
    'Get the app hwnd.
    lXLhwnd = FindWindow("XLMAIN", Application.Caption)

    Do
        WaitMessage

        'Exit the loop if we were aborted
        If bExitLoop Then Exit Do

        'Check for a key press and remove it from the msg queue.
        If PeekMessage(msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            'Store the virtual key code for later use.
            iMessage = msgMessage.Message
            iKeyCode = msgMessage.wParam

            'Translate the virtual key code into a char msg.
            TranslateMessage msgMessage
            PeekMessage msgMessage, lXLhwnd, WM_CHAR, WM_CHAR, PM_REMOVE

            bCancel = False
            RaiseEvent KeyPressed(msgMessage.wParam, iKeyCode, Selection, bCancel)

            'If not handled, post back to the window using the original values
            If Not bCancel Then
                PostMessage lXLhwnd, iMessage, iKeyCode, 0
            End If
        End If
errHandler:
        'Allow the processing of other msgs.
        DoEvents
    Loop Until bExitLoop
End Sub

Public Sub StopKeyPressWatch()
    'Set this boolean flag to exit the above loop.
    bExitLoop = True
End Sub

Usage

Option Explicit

Dim WithEvents CKeyWatcher As KeyPressApi

Private Sub Worksheet_Activate()
    If CKeyWatcher Is Nothing Then
        Set CKeyWatcher = New KeyPressApi
    End If
    CKeyWatcher.StartKeyPressInit
End Sub

Private Sub Worksheet_Deactivate()
    CKeyWatcher.StopKeyPressWatch
End Sub

'\\This example illustrates how to catch worksheet
'\\Key strokes in order to prevent entering numeric
'\\characters in the Range "A1:D10" .
Private Sub CKeyWatcher_KeyPressed(ByVal KeyAscii As Integer, _
                                   ByVal KeyCode As Integer, _
                                   ByVal Target As Range, _
                                   Cancel As Boolean)

    Const MSG As String = _
    "Numeric Characters are not allowed in" & _
    vbNewLine & "the Range:  """
    Const TITLE As String = "Invalid Entry !"

    If Not Intersect(Target, Range("A1:D10")) Is Nothing Then
        If Chr(KeyAscii) Like "[0-9]" Then
            MsgBox MSG & Range("A1:D10").Address(False, False) _
            & """ .", vbCritical, TITLE
            Cancel = True
        End If
    End If

End Sub

#3

I had the same problem, and solved it by placing a text box over the cell. I set the properties so that the text box looked like an Excel cell, then used the Top and Left properties to position it over the cell using the same properties from the cell, and set the Width and Height to be one more than that of the cell. Then I made it visible. I used the KeyDown event to process the keystrokes. In my code I positioned a list box under the cell to display the matching items from a list on another sheet. Note: This code was in the sheet, the Cell variable was declared in a module: Global Cell as Range. This works much better than a combo box. tb1 is a text box, and lb1 is a list box. You will need a sheet named Fruit with data in the first column. The sheet that this code runs in will only run if the selected cell is in column = 2, and is empty. Don't forget to declare Cell as mentioned above.

我有同样的问题，并通过在单元格上放置一个文本框来解决它。我设置属性，使文本框看起来像一个Excel单元格，然后使用Top和Left属性使用单元格中相同的属性将其放置在单元格上，并将宽度和高度设置为比单元格的宽度和高度多一个。细胞。然后我让它可见。我使用KeyDown事件来处理击键。在我的代码中，我在单元格下方放置了一个列表框，以显示另一个工作表上列表中的匹配项。注意：此代码位于工作表中，Cell变量在模块中声明：Global Cell as Range。这比组合框好得多。 tb1是一个文本框，lb1是一个列表框。在第一列中，您将需要一个名为Fruit的工作表和数据。此代码运行的工作表仅在所选单元格位于column = 2且为空时才会运行。不要忘记如上所述声明Cell。

Option Explicit

Private Sub lb1_Click()
  Cell.Value2 = lb1.Value
  tb1.Visible = False
  lb1.Visible = False
  Cell.Activate
End Sub

Private Sub tb1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim Row As Long
Dim Temp As String
  Select Case KeyCode
  Case vbKeyBack
    If Len(tb1.Value) > 0 Then tb1.Value = Left(tb1.Value, Len(tb1.Value) - 1)
  Case vbKeySpace, vbKeyA To vbKeyZ
    tb1.Value = WorksheetFunction.Proper(tb1.Value & Chr(KeyCode))
  Case vbKeyReturn
    If lb1.ListCount > 0 Then
      Cell.Value2 = lb1.List(0)
    Else
      Cell.Value2 = tb1.Value
      With Sheets("Fruit")
        .Cells(.UsedRange.Rows.Count + 1, 1) = tb1.Value
        .UsedRange.Sort Key1:=.Cells(1, 1), Header:=xlYes
      End With
      MsgBox tb1.Value & " has been added to the List"
    End If
    tb1.Visible = False
    lb1.Visible = False
    Cell.Activate
  Case vbKeyEscape
    tb1.Visible = False
    lb1.Visible = False
    Cell.Activate
  End Select
  lb1.Clear
  Temp = LCase(tb1.Value) & "*"
  With Sheets("Fruit")
    For Row = 2 To .UsedRange.Rows.Count
      If LCase(.Cells(Row, 1)) Like Temp Then
        lb1.AddItem .Cells(Row, 1)
      End If
    Next Row
  End With
KeyCode = 0
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Target.Column = 2 And Target.Cells.Count = 1 Then
    If Target.Value2 = Empty Then
      Set Cell = Target
      With Cell
        tb1.Top = .Top
        tb1.Left = .Left
        tb1.Height = .Height + 1
        tb1.Width = .Width + 1
      End With
      tb1.Value = Empty
      tb1.Visible = True
      tb1.Activate
      With Cell.Offset(1, 0)
        lb1.Top = .Top
        lb1.Left = .Left
        lb1.Width = .Width + 1
        lb1.Clear
        lb1.Visible = True
      End With
    Else
      tb1.Visible = False
      lb1.Visible = False
    End If
  Else
    tb1.Visible = False
    lb1.Visible = False
  End If
End Sub