VBA - Making the double click event unique

R

REUBEN

Board Regular
Joined
Mar 7, 2014
Messages
113
Hi All,

I run the following code to capture the current time in certain fields. All that the user does is double clicks a cell to enter the current time. However, if they in error click the field again, then it overwrites the captured time with the current time.

Is it possible to exit the double click event sub if the field already has a time recorded in it?

Here's the code I am using:

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)    
    Dim StartCell As String
    Dim EndCell As String
    
    'TaskCell = "2"
    StartCell = "6"
    EndCell = "8"
    Breakwatch = "7"
    'MinimizeWB = ActiveWorkbook.ActiveSheet("Sheet1").Range("K2")
    
    Select Case ActiveCell.Column
        Case StartCell ' Address of start cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(0, 1).Select
            Target.Offset(0, 1).Value = "Double Click To Enter Break Time"
            Target.Offset(0, 1).Font.Size = 7
            'Target.Offset(0, 1).WrapText = True
            Target.Offset(0, 2).Value = "Double Click To Enter End Time"
            Target.Offset(0, 2).Font.Size = 7
            'Target.Offset(0, 2).WrapText = True
            Target.Offset(1, -4).Value = "Enter Brief Details on Next Case or Task"
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(0, -1).Value = Date
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(1, -1).Value = "--SKIP THIS CELL--" _
            & "             Date Will Get Entered Here Automatically"
            Target.Offset(0, -1).WrapText = True
            Target.Offset(1, -1).Font.Size = 7
            Target.Offset(1, 0).Value = "Double Click To Enter Start Time of Next Task"
            Target.Offset(1, 0).Font.Size = 7
        Case EndCell ' Address of end cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(1, -6).Select
        Case Breakwatch
            stopped = False
            UserForm1.Show 'vbModeless
            If stopped Then
                Target.Value = Format(Time - start, "hh:mm:ss")
                Target.Offset(0, 1).Select
                Target.Font.Size = 10
            End If
            With Me
                UserForm1.TextBox2.Text = Cells(ActiveCell.Row, "B").Value
            End With
         Case Else
         
    End Select


End Sub

Thank you for your help.
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
You could test for a number in the cell:

Code: 
    If IsNumeric(Target.Value) Then Exit Sub

You may also want to set Cancel = True to avoid entering edit mode in the cell.
 
Last edited:
Upvote 0
Try this:

Added lines of code marked in red:

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim StartCell As String
    Dim EndCell As String
    
    'TaskCell = "2"
    StartCell = "6"
    EndCell = "8"
    Breakwatch = "7"
    'MinimizeWB = ActiveWorkbook.ActiveSheet("Sheet1").Range("K2")
    [COLOR=#ff0000]If Target.Value = "" Then[/COLOR]
    Select Case ActiveCell.Column
        Case StartCell ' Address of start cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(0, 1).Select
            Target.Offset(0, 1).Value = "Double Click To Enter Break Time"
            Target.Offset(0, 1).Font.Size = 7
            'Target.Offset(0, 1).WrapText = True
            Target.Offset(0, 2).Value = "Double Click To Enter End Time"
            Target.Offset(0, 2).Font.Size = 7
            'Target.Offset(0, 2).WrapText = True
            Target.Offset(1, -4).Value = "Enter Brief Details on Next Case or Task"
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(0, -1).Value = Date
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(1, -1).Value = "--SKIP THIS CELL--" _
            & "             Date Will Get Entered Here Automatically"
            Target.Offset(0, -1).WrapText = True
            Target.Offset(1, -1).Font.Size = 7
            Target.Offset(1, 0).Value = "Double Click To Enter Start Time of Next Task"
            Target.Offset(1, 0).Font.Size = 7
        Case EndCell ' Address of end cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(1, -6).Select
        Case Breakwatch
            stopped = False
            'UserForm1.Show 'vbModeless
            If stopped Then
                Target.Value = Format(Time - Start, "hh:mm:ss")
                Target.Offset(0, 1).Select
                Target.Font.Size = 10
            End If
            With Me
                'UserForm1.TextBox2.Text = Cells(ActiveCell.Row, "B").Value
            End With
         Case Else
         
    End Select
[COLOR=#ff0000]End If[/COLOR]
End Sub
 
Upvote 0
My Aswer Is This said:
Try this:

Added lines of code marked in red:

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim StartCell As String
    Dim EndCell As String
    
    'TaskCell = "2"
    StartCell = "6"
    EndCell = "8"
    Breakwatch = "7"
    'MinimizeWB = ActiveWorkbook.ActiveSheet("Sheet1").Range("K2")
    [COLOR=#ff8c00]If (Target.Value = 0 Or Target.Value = "Double Click To Enter Break Time" Or Target.Value = "Double Click To Enter End Time") Then[/COLOR]
    Select Case ActiveCell.Column
        Case StartCell ' Address of start cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(0, 1).Select
            Target.Offset(0, 1).Value = "Double Click To Enter Break Time"
            Target.Offset(0, 1).Font.Size = 7
            'Target.Offset(0, 1).WrapText = True
            Target.Offset(0, 2).Value = "Double Click To Enter End Time"
            Target.Offset(0, 2).Font.Size = 7
            'Target.Offset(0, 2).WrapText = True
            Target.Offset(1, -4).Value = "Enter Brief Details on Next Case or Task"
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(0, -1).Value = Date
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(1, -1).Value = "--SKIP THIS CELL--" _
            & "             Date Will Get Entered Here Automatically"
            Target.Offset(0, -1).WrapText = True
            Target.Offset(1, -1).Font.Size = 7
            Target.Offset(1, 0).Value = "Double Click To Enter Start Time of Next Task"
            Target.Offset(1, 0).Font.Size = 7
        Case EndCell ' Address of end cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(1, -6).Select
        Case Breakwatch
            stopped = False
            'UserForm1.Show 'vbModeless
            If stopped Then
                Target.Value = Format(Time - Start, "hh:mm:ss")
                Target.Offset(0, 1).Select
                Target.Font.Size = 10
            End If
            With Me
                'UserForm1.TextBox2.Text = Cells(ActiveCell.Row, "B").Value
            End With
         Case Else
         
    End Select
[COLOR=#ff0000]End If[/COLOR]
End Sub
Click to expand...


Thanks so much. I tried it and it worked well. But then I realised that from the rest of the code I also auto populate certain texts. in the next two corresponding fields. And the code doesnt work in that case. So I modified the IF argument accordingly (in orange text), but that didn't do the trick.

Could you point out what I am doing wrong?
 
Last edited:
Upvote 0
So I played around with the code a bit more and got this to work.

Code: 
 If (Target.Value > Format(Time, "hh:mm:ss") Or Target.Value = "Double Click To Enter End Time") Then

Thank you all for your help.
 
Upvote 0
You may want to consider something like this:
It would put a comment in the cell instead of text.

I worked on some of it but not all.

And when you entered a value into a cell and it had a comment showing the comment would then be deleted.

Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim StartCell As String
    Dim EndCell As String
    Cancel = True
    Application.EnableEvents = False
    'TaskCell = "2"
    StartCell = "6"
    EndCell = "8"
    Breakwatch = "7"
    'MinimizeWB = ActiveWorkbook.ActiveSheet("Sheet1").Range("K2")
    If (Target.Value = 0 Or Target.Value = "Double Click To Enter Break Time" Or Target.Value = "Double Click To Enter End Time") Then
    Select Case ActiveCell.Column
        Case StartCell ' Address of start cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(0, 1).Select
            Target.Offset(0, 1).AddComment "Double Click To Enter Break Time"
            Target.Offset(0, 1).Font.Size = 7
            'Target.Offset(0, 1).WrapText = True
            Target.Offset(0, 2).AddComment "Double Click To Enter End Time"
            Target.Offset(0, 2).Font.Size = 7
            'Target.Offset(0, 2).WrapText = True
            Target.Offset(1, -4).AddComment "Enter Brief Details on Next Case or Task"
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(0, -1).Value = Date
            Target.Offset(0, -1).Font.Size = 9
            Target.Offset(1, -1).AddComment "SKIP THIS CELL" & vbNewLine & "Date Will Get Entered Here Automatically"
            Target.Offset(0, -1).WrapText = True
            Target.Offset(1, -1).Font.Size = 7
            Target.Offset(1, 0).AddComment "Double Click To Enter Start Time of Next Task"
            Target.Offset(1, 0).Font.Size = 7
        Case EndCell ' Address of end cell
            Target.Value = Format(Time, "hh:mm:ss")
            Target.Font.Size = 10
            Target.Offset(1, -6).Select
        Case Breakwatch
            stopped = False
            'UserForm1.Show 'vbModeless
            If stopped Then
                Target.Value = Format(Time - Start, "hh:mm:ss")
                Target.Offset(0, 1).Select
                Target.Font.Size = 10
            End If
            With Me
                'UserForm1.TextBox2.Text = Cells(ActiveCell.Row, "B").Value
            End With
         Case Else
         
    End Select
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Comment Is Nothing Then
  
  Else
  If Target.Column = 2 Then Target.Comment.Delete
  End If
End Sub
 
Upvote 0
Thanks for your reply.

The code had some issues with the first IF argument as it would not really do anything. so I changed it to
Code: 
[COLOR=#333333]Target.Value > [/COLOR][COLOR=#333333]Format(Time, "hh:mm:ss")[/COLOR]

That was inserting the current time in the start time column, but then excel started to hang... this has happened a few times now. So I've stopped with this idea.

Thank you anyway with your help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
color cell in red, when entering empty time value
Replies
2
Views
172
robertvdb
R
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
912
Legacy 352679
L
G
  • Solved
run VBA when clicked
Replies
4
Views
116
Gylle
G
H
  • Solved
Double Click Cell to cell to Sheet Name and Cell
2
Replies
11
Views
812
howard
H
P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
88
6StringJazzer
6StringJazzer

Forum statistics

Threads
1,223,911
Messages
6,175,329
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top