How can I count, using VBA, the no of clicks on each cell inside a specified range in Excel?-CodePudding

Let's say I want to click in a certain sheet of an excel file on cells:

A1 - 3 times
A2 - 5 times
B1 - 10 times
B2 - 20 times

I'd like the output to show the number of clicks in each cell, as I am clicking them (https://i.stack.imgur.com/1KfHT.png). How can I obtain this? I've been trying many variants of the code below, without success.

Many thanks!

Sub Worksheet_SelectionChange(ByVal Target As Range)

For Each cell In Range("A1:B2")
    xNum = 0    
    On Error Resume Next
    
    Set myRange = cell
    If cell Is Nothing Then Exit Sub
    
    If Intersect(myRange, Target) Is Nothing Then Exit Sub
    
    xNum = xNum   1
    MyRange.Value = xNum
    
Next cell
End Sub

CodePudding user response：

Count the Number of Clicks on Each Cell of a Range...

... and write the count to the clicked cell.
Upon clicking a cell of the source range, the value in the cell is increased by one and the cell and the last cell of the worksheet become selected.
The idea was taken from Super Simmetry's answer to the question "OnClick in Excel VBA".
The idea, of how to exclude the navigation keys to trigger the event, was taken from Jaafar Tribak's first answer to the question "Mouse click event". He has also posted another (newer) post as an improvement which I haven't studied but looks promising (in getting rid of the 'hack' part).
Since this doesn't do exactly what is required, your feedback is highly appreciated.
Copy the complete code into the sheet module (e.g. Sheet1) of the worksheet to where it needs to be applied.
There's nothing to run, it runs automatically upon each click on a cell in the worksheet.

Option Explicit

' This declaration may be wrong!!!
' It's working in my 64bit Office 2019 using Windows 10 64bit.
#If VBA7 Then
    Private Declare PtrSafe Function GetAsyncKeyState _
        Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function GetAsyncKeyState _
        Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private Const RangeAddress As String = "A1:B2"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:        CountRangeClicks
'                   WasNavigationKeyPressed
'                       GetAsyncKeyState
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub WorkSheet_SelectionChange(ByVal Target As Range)
    CountRangeClicks Target, RangeAddress
End Sub

' To reset the values to zero upon double-clicking any of the source cells,
' you could use the following event procedure.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim srg As Range: Set srg = Me.Range(RangeAddress)
    If Intersect(srg, Target) Is Nothing Then Exit Sub
    srg.Value = 0
    Cancel = True
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:        WasNavigationKeyPressed
'                   GetAsyncKeyState
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CountRangeClicks( _
        ByVal Target As Range, _
        ByVal RangeAddress As String)
    
    If WasNavigationKeyPressed Then Exit Sub ' only 'mouse-selection'
    If Target.Cells.CountLarge > 1 Then Exit Sub ' only one cell selection
    
    Dim ws As Worksheet: Set ws = Target.Worksheet
    
    Dim srg As Range: Set srg = ws.Range(RangeAddress)
    If Intersect(srg, Target) Is Nothing Then Exit Sub
    
    ' The Hack (Not quite what is required)
    
    ' The trick is in selecting the target cell ('tCell') and another cell
    ' (I've opted for the last cell in the worksheet)('uCell').
    ' For more detail, see Super Symmetry's post at
    ' https://stackoverflow.com/a/61377786
    
    Dim tCell As Range: Set tCell = Target
    Dim uCell As Range: Set uCell = ws.Cells(ws.Cells.CountLarge)
    
    Application.EnableEvents = False
        Union(tCell, uCell).Select
    Application.EnableEvents = True
    ' Only if any of the source cells ('srg') is clicked on,
    ' the last worksheet cell becomes selected with it.
    
    ' Validate and count (write).
    
    Dim tValue As Variant: tValue = tCell.Value
    
    Dim IsWholeNumber As Boolean
    
    If VarType(tValue) = vbDouble Then ' is a number
        If Int(tValue) = tValue Then ' is an integer
            If tValue >= 0 Then ' is a whole number (0, 1, 2...)
                IsWholeNumber = True
            End If
        End If
    End If
    
    If IsWholeNumber Then
        tCell.Value = tCell.Value   1
    Else
        tCell.Value = 1
    End If
    
End Sub

' Calls the 'GetAsyncKeyState' Windows API
' Not entirely sure what's going on here (`And &H8000`)!!!
' For more detail, see Jaafar Tribak's post at
' https://www.mrexcel.com/board/threads/mouse-click-event.208072
Function WasNavigationKeyPressed() As Boolean
    
    Dim NavigationKeys As Variant: NavigationKeys = Array( _
        vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, _
        vbKeyTab, vbKeyReturn, vbKeyHome, vbKeyEnd, vbKeyPageDown, vbKeyPageUp)
    
    Dim Item As Variant

    For Each Item In NavigationKeys
        If CBool(GetAsyncKeyState(Item) And &H8000) Then
            WasNavigationKeyPressed = True
            Exit Function
        End If
    Next Item
    
End Function

CodePudding user response：

Is this what you're after?

Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    ' declare range
    Dim MyRange As Range

    ' range to check for clicks
    Set MyRange = Me.Range("A1:A2")

    ' ensure cell selected is within MyRange, drop out if not
    If Intersect(MyRange, Target) Is Nothing Then Exit Sub

    ' increment  1 the value of the cells, offset to the right by one
    Target.offset(0, 1).Value = Target.offset(0, 1).Value   1
    
    ' disable events to prevent loop (not entirely necessary, but wise)
    Application.EnableEvents = False
    
    ' change activated cell one to the right to allow re-click
    Target.offset(0, 1).Activate
    
    ' enable events
    Application.EnableEvents = True

End Sub