Timer In Status Bar

[Dazzawm]

Is there anyway that a timer can be put in a workbook and counts up every time its opened? When I start a new project I want to see how long it takes, so from the moment I start it I want it to count up and then stop when I close it. Then when I open it again the next day I want it to continue from where it left of and so on. Possible? Thanks.

 

[Dazzawm]

Warship,

1). When I exit out of the workbook, it asks me if I want to save the workbook. Whether I click yes or no, the workbook doesn't close. The only way to get the workbook to close is by exiting excel entirely.

It is actually doing that for me to. I try to close the workbook, save and it reopens again. I need to ctrl+alt+del to get out of it!

 

[Warship]

Hopefully this will resolve your closing issues.
If it doesn't, I would suggest changing the updateSecs to = 60
to update by the minute instead of by the second.

Also to drop the seconds from displaying,
change "[h]:mm:ss" to "[h]:mm" in both places.

I'm have yet to look at the "Template" solution.

Option Explicit
Dim StartTime
Dim EndTime
Dim RunAt
Dim oldStatBar
Public SessionTime
Public TotalTime
Const updateSecs = 1 'interval of seconds to update status bar
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                            '
'   Call StartProjTime from Private Sub Workbook_Open        '
'                                                            '
'   Call EndProjTime from Private Sub Workbook_BeforeClose   '
'                                                            '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub UpdateProjTime()
    StartTime = Evaluate("StartTime")
    TotalTime = Evaluate("TotalTime")
    EndTime = Now
    SessionTime = EndTime - StartTime
    Application.StatusBar = "Session Time: " & _
        Application.WorksheetFunction.Text(SessionTime, "[h]:mm:ss") & _
        " | Total Time: " & _
        Application.WorksheetFunction.Text(TotalTime + SessionTime, "[h]:mm:ss")
    TimerStart
End Sub

Sub StartProjTime()
    If IsError(Evaluate("TotalTime")) Then ProjectTimeSetup
    ThisWorkbook.Names("StartTime").RefersTo = Now
    oldStatBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    UpdateProjTime
End Sub

Sub EndProjTime()
    If IsError(Evaluate("TotalTime")) Then Exit Sub
    UpdateProjTime
    TimerStop
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatBar
    ThisWorkbook.Names("TotalTime").RefersTo = TotalTime + SessionTime
End Sub

Private Sub TimerStart()
    RunAt = Now + TimeSerial(0, 0, updateSecs)
    Application.OnTime _
        EarliestTime:=RunAt, _
        Procedure:="UpdateProjTime"
End Sub

Private Sub TimerStop()
    On Error Resume Next
    Application.OnTime _
        EarliestTime:=RunAt, _
        Procedure:="UpdateProjTime", _
        Schedule:=False
    On Error GoTo 0
End Sub

Private Sub ProjectTimeSetup()
    Dim arr As Variant, n As Variant
    arr = Array("StartTime", "TotalTime")
    For Each n In arr
    If IsError(Evaluate(n)) Then _
        ThisWorkbook.Names.Add Name:=n, RefersTo:=0
    Next n
End Sub

Option Explicit

Private Sub Workbook_Open()
    StartProjTime
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    EndProjTime
End Sub

 

[Dazzawm]

Thanks warship that seems to have worked.

 

[Warship]

Template solution:
Creates Workbook template and sets to Read Only.

Option Explicit
Dim StartTime
Dim EndTime
Dim RunAt
Dim oldStatBar
Public SessionTime
Public TotalTime
Const updateSecs = 1 'interval of seconds to update status bar
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                            '
'   Call StartProjTime from Private Sub Workbook_Open        '
'                                                            '
'   Call EndProjTime from Private Sub Workbook_BeforeClose   '
'                                                            '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub UpdateProjTime()
    StartTime = Evaluate("StartTime")
    TotalTime = Evaluate("TotalTime")
    EndTime = Now
    SessionTime = EndTime - StartTime
    Application.StatusBar = "Session Time: " & _
        Application.WorksheetFunction.Text(SessionTime, "[h]:mm:ss") & _
        " | Total Time: " & _
        Application.WorksheetFunction.Text(TotalTime + SessionTime, "[h]:mm:ss")
    TimerStart
End Sub

Sub StartProjTime()
    If IsError(Evaluate("TotalTime")) Then ProjectTimeSetup
    ThisWorkbook.Names("StartTime").RefersTo = Now
    oldStatBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    UpdateProjTime
End Sub

Sub EndProjTime()
    If IsError(Evaluate("TotalTime")) Then Exit Sub
    UpdateProjTime
    TimerStop
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatBar
    ThisWorkbook.Names("TotalTime").RefersTo = TotalTime + SessionTime
End Sub

Private Sub TimerStart()
    RunAt = Now + TimeSerial(0, 0, updateSecs)
    Application.OnTime _
        EarliestTime:=RunAt, _
        Procedure:="UpdateProjTime"
End Sub

Private Sub TimerStop()
    On Error Resume Next
    Application.OnTime _
        EarliestTime:=RunAt, _
        Procedure:="UpdateProjTime", _
        Schedule:=False
    On Error GoTo 0
End Sub

Private Sub ProjectTimeSetup()
    Dim arr As Variant, n As Variant
    Dim response As String, fName
    arr = Array("StartTime", "TotalTime")
    For Each n In arr
    If IsError(Evaluate(n)) Then _
        ThisWorkbook.Names.Add Name:=n, RefersTo:=0
    Next n
    response = MsgBox("Create Template?", vbYesNo, "")
    If response = vbNo Then Exit Sub
    Do: fName = Application.GetSaveAsFilename
    Loop Until fName <> False
    ThisWorkbook.SaveAs Filename:=fName & "xltm", _
        FileFormat:=xlOpenXMLTemplateMacroEnabled
    SetAttr fName & "xltm", vbReadOnly
    ThisWorkbook.Close False
End Sub

 

[Warship]

Thanks warship that seems to have worked.

You are quite welcome.