VB Macro to capture mouseclick on excel sheet cell

[Ollie123]

Hi,
I've had a search of the forums but either haven't found what I need or understood what I've read. I wish to have a VB macro constantly running on a particular worksheet which will increment the value of a cell when that cell is clicked on with the mouse.

The best I've come up with is:
Public Sub lkjhg()

ActiveCell.Value = ActiveCell.Value + 1

End Sub

It only runs once when the 'run' button is pressed. I haven't been able to implement a MouseDown event.

Any advice would be great and appreciated. I'm running Excel 2007.
Thanks.

 

[njimack]

Paste the following into your sheet module, change the target address to the cell in question...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target.Count = 1 And Target.Address = "$A$1" Then Target.Value = Target.Value + 1
Application.EnableEvents = True
End Sub

 

[lenze]

Hi and welcome to the board!!
I would amend njimack's code to a DoubleClick. Much less chance of increasing the value by accident

Private Sub WorkSheet_BeforeDoubleClick(ByVal Target as Range, Cancel as Boolean)
If Target. Address = "$A$1" Then 
   Target = Target + 1
End If
Cancel = True
End Sub

You can Subtract with a RightClick

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = "$A$1" Then
    Target = Target - 1
    End If
Cancel = True
End Sub

lenze

 

[Ollie123]

thanks guys, I'll try the code tomorrow. Is it possible though to not pre-specify the cell in question -- I want to be able to click on any cell in any order for as long as the sheet is open. Do I simply remove the target cell reference?

I'll work through it in any case. Thanks again.

 

[lenze]

To answer your question, you can remove the reference to allow the codes to run on ALL cells, or you can specify Columns or Ranges

If Target.Column = 3 Then ' Test for Column "C"
 
If Not Intersect(Target(Range("$A$1:$D$10")) Is Nothing Then ' test for Range A1:D10

Numerous other ways depending on your needs.

You can also run different code depending on which Cell(s) is chosen!

lenze

 

[Jaafar Tribak]

Hi. The above solutions rely on the selection_change event which will not work if Cell A1 is already selected. It will only work if you first select another cell then select A1.

Here is an improved version of some code I posted here before which imitates a propper On_Click event and which overcomes the above limitation:

Workbook Demo

Code in the Workbook module :

Option Explicit
 
Public Event Click(ByVal Target As Range)
 
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 FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) 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 WaitMessage Lib "user32" _
() As Long
 
Private Const XL_CLASS_NAME As String = "XLMAIN"
Private Const XLDESK_CLASS_NAME As String = "XLDESK"
Private Const XLBOOK_CLASS_NAME As String = "EXCEL7"
 
Private Const PM_NOREMOVE As Long = &H0
Private Const WM_LBUTTONDOWN As Long = &H201
 
Private bStopLoop As Boolean
 
Private Sub Workbook_Open()
 
   If ActiveSheet Is Sheets(1) Then _
   Call SetClickEvent(TargetSheet:=Sheets(1))
 
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    Call StopClickEvent
 
End Sub
 
Private Sub SetClickEvent(TargetSheet As Worksheet)
 
    Dim tMsg As MSG
    Dim lXlhwnd As Long, lDeskhwnd As Long, lBookhwnd As Long
 
    'hook our target worksheet.
    CallByName TargetSheet, "Worksheet_", VbSet, ThisWorkbook
    'get the workbook hwnd.
    lXlhwnd = FindWindow _
    (XL_CLASS_NAME, Application.Caption)
    lDeskhwnd = FindWindowEx _
    (lXlhwnd, 0, XLDESK_CLASS_NAME, vbNullString)
    lBookhwnd = FindWindowEx _
    (lDeskhwnd, 0, XLBOOK_CLASS_NAME, vbNullString)
 
    'prevent unintentionnal exit of the
    'loop if the cancel key is pressed.
    Application.EnableCancelKey = xlErrorHandler
    On Error GoTo err_Handler
 
    'reinitialize the boolean flag.
    bStopLoop = False
    Do
        'wait for an input msg.
        WaitMessage
        'did the user perform a mouse click ?
        If PeekMessage _
            (tMsg, lBookhwnd, _
            WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_NOREMOVE) Then
            'are we on our target sheet ?
            If ActiveSheet Is TargetSheet Then
            'are we clicking a cell ?
            If TypeName _
            (ActiveWindow.RangeFromPoint(tMsg.pt.x, tMsg.pt.y)) _
            = "Range" Then
                'If so,execute our custom sheet click event.
                DoEvents
                RaiseEvent Click(Selection)
            End If
        End If
        End If
        'allow the processing of other msgs.
        DoEvents
    Loop Until bStopLoop
 
    Exit Sub
err_Handler:
    Call SetClickEvent(TargetSheet)
 
End Sub
 
Private Sub StopClickEvent()
 
    'set this flag to exit the loop.
    bStopLoop = True
    'reset the normal cancel key behaviour.
    Application.EnableCancelKey = xlInterrupt
 
End Sub
 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 
    If Sh Is Sheets(1) And bStopLoop Then _
    Call SetClickEvent(TargetSheet:=Sheets(1))
 
    If Not Sh Is Sheets(1) Then Call StopClickEvent
 
End Sub

And this goes in the worksheet module : (Sheets(1))

Option Explicit
 
Public WithEvents Worksheet_ As ThisWorkbook
 
Private Sub Worksheet__Click(ByVal Target As Range)
 
    If Target.Address = "$A$1" Then
 
        MsgBox "You clicked Cell : " & _
        Target.Address, vbInformation
 
        'do other stuff here..........
 
        Target = Target + 1
 
    End If
 
End Sub