• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to record Start and End time

A

ashish navale

New Member
Hi,


I am developing a production tracker. In this tracker the start and end time should be generated automatically. I will explain my requirement in detail.


Format of my tracker is as below:

Column A (Date), Column B (Request Id), Column D,E & F are part of Process, Column G(Start Time), Column H (End Time), Column I(Duration)


1.Eg. Now here when I enter any data in column B on cell B9, the system time should be shown in start time in Col G on cell G9.


2. When I go on next line and enter data in column B on cell B10, again it will reflect system time as start time in Col G on cell G10. So now whatever start time is shown on cell G10 should reflect as End Time on Column H in cell H9 which will become End Time automatically.


Basically the macro will work in way like when data is entered in respective cell, it will display start time and when entry is made on next line, its start time should make a copy in End time of previous entry. In this way I will not have to enter time manually.


One more thing, start and end time should not change after the entry is over. Ex. If I make 10 entries and I realise that on 2nd entry Case Id(Cell B3) is different, when I attempt to change it, the time should not change.


Please help me with a solution as its my managers requirement.
 
How's this?

[pre]
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:F")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub 'Can't handle multi-cell changes

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim TimeStamp As Double

'Was the time stamp previously empty?
If Cells(Target.Row, "G") = "" Then
TimeStamp = Now
Cells(Target.Row, "G").Value = TimeStamp
If Target.Row <> 2 Then
Cells(Target.Row - 1, "H").Value = TimeStamp
End If
End If

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/pre]
 
Hi Luke...this macro is working wonderful..could you please help me with one more solution. I want the start and end time to be locked automatically after entry is over so as to avoid any changes..so can it be adjusted in above macro itself.
 
First, have format the cells in columns A:F on th eProtection tab, to be unlocked, and make sure columns G:H are formatted as locked. Then we can modify macro to this:

[pre]
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:F")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub 'Can't handle multi-cell changes

Application.ScreenUpdating = False
Application.EnableEvents = False
Me.Unprotect

Dim TimeStamp As Double

'Was the time stamp previously empty?
If Cells(Target.Row, "G") = "" Then
TimeStamp = Now
Cells(Target.Row, "G").Value = TimeStamp
If Target.Row <> 2 Then
Cells(Target.Row - 1, "H").Value = TimeStamp
End If
End If

Me.Protect
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/pre]
 
HI Luke, The above macro worked fantastic. Now I am facing a small problem which I forgot to share with you in advance. When I share the workbook I get error "Method 'Protect' of object'_Worksheet' failed". Maybe because when workbook is shared it does not allow to protect cells. Is there any solution to use above macro in shared workbook without any error?
 
Yikes. Shared workbooks open up a whole other list of issues...

Maybe we could add a check at the beginning?

[pre]
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Application.EnableEvents = False

If Not (Intersect(Target, Range("G:H")) Is Nothing) Then
Application.Undo
MsgBox "Don't touch these cells." & vbNewLine & "They are filled in automatically.", vbOKOnly, "Columns G:H"
GoTo EscapeSub
End If
If Intersect(Target, Range("A:F")) Is Nothing Then GoTo EscapeSub
If Target.Count > 1 Then GoTo EscapeSub 'Can't handle multi-cell changes

Dim TimeStamp As Double

'Was the time stamp previously empty?
If Cells(Target.Row, "G") = "" Then
TimeStamp = Now
Cells(Target.Row, "G").Value = TimeStamp
If Target.Row <> 2 Then
Cells(Target.Row - 1, "H").Value = TimeStamp
End If
End If

EscapeSub:

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/pre]
Macro automatically undoes any changes that are made to Cols G:H, no longer uses sheet protection.
 
Hi Luke..the macro given by you worked fantastic. Everybody in my team were impressed with your knowledge of macros. Now I am given responsibility to develop trackers for two more projects. But now this time I am expected to make a slight change. When I enter data in column B the system time will display automatically in column G as Start Time as previously indicated. But now I need the End time(Col H) to be displayed automatically when I enter any data in comments column which is Column J of same row. I hope you will have a solution for this too.
 
Luke...in the above post I forgot to mention one thing..the trackers are going to be the shared workbooks...so as per my convinience I wish to have the above said feature added in last macro code given by you..I know you can do it.. :)
 
Hi ashish,

As it has been the weekend here in the US, I have not been on the past couple of days. So, all we care about now is col B and J? How's this?

[pre]
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Application.EnableEvents = False

If Not (Intersect(Target, Range("G:H")) Is Nothing) Then
Application.Undo
MsgBox "Don't touch these cells." & vbNewLine & "They are filled in automatically.", vbOKOnly, "Columns G:H"
GoTo EscapeSub
End If
'Start time
If Not (Intersect(Target, Range("B:B")) Is Nothing) Then
If Cells(Target.Row, "G") = "" Then
Cells(Target.Row, "G") = Now
End If

'End time
ElseIf Not (Intersect(Target, Range("J:J")) Is Nothing) Then
If Cells(Target.Row, "H") = "" Then
Cells(Target.Row, "H") = Now
End If
End If

EscapeSub:

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
[/pre]
 
Hi Luke, Thank you so much..

The Macro worked wonderful. I appreciate your knowledge of excel and macros specially. Only because of you I was able to complete my task successfully...Thanks once again :)
 
Hi ,


It's neither ; it is a method to return a Range object that represents the rectangular intersection of two or more ranges.


http://msdn.microsoft.com/en-us/library/office/aa195772(v=office.11).aspx


http://msdn.microsoft.com/en-us/library/office/ff835030.aspx


http://www.excely.com/excel-vba/using-intersection-to-create-a-range.shtml


Narayan
 
You must log in or register to reply here.
Back
Top