• 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.

Time Management

S

stupidname

New Member
Hello People


I need some help please. I get constantly distracted and want to log distraction easily.

Is it possible to have a stop and start vba macro, which logs the date (dd/mm/yy) in one column, the time in the other (i'll fill time bandit manually)


Hopefully over a month it will clearly state why i stuff is not getting done!


Any help or advice would be much appreciated.


Ta very much!


Dan
 
Hello Dan,

You may want to check out:

http://www.techsupportalert.com/best-free-project-time-keeping-utility.htm


There are many freeware tools already available with varying features.


Cheers,

Sajan.
 
Why reinvent the wheel - thank you for your quick response.

However I can't download anything in work or use usb - its like Fort Knox!


Any other recommendations please?
 
Hi, Dan Druff!

Don't worry about being unable to download anything, if it's like Fort Knox we're all most interested in your availability for uploading things... maybe a couple of those golden bricks? :)

Regards!
 
Hi, Dan Druff!


Give a look to this link:

http://chandoo.org/forums/topic/help-with-macro-for-dynamically-track-elapsed-time-with-5minute-visual-alarms

specially this post:

http://chandoo.org/forums/topic/help-with-macro-for-dynamically-track-elapsed-time-with-5minute-visual-alarms#post-105859


It's not the same stuff you're looking for but maybe you could extract any idea from it. As you can't access shared files I'm posting here the VBA code involved:


ThisWorkbook:

-----

[pre]
Code: 
Option Explicit

Private Sub Workbook_Open()
TrackingStart
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
TrackingStop
End Sub
[/pre]
-----

Any module:

-----

Option Explicit

' public constants
' ws & ranges
'Public Const pgksWSTask = "Hoja1" -----> Activesheet
Public Const pgksTask = "TaskTable"
Public Const pgksParamOnOff = "ParamOnOff"
Public Const pgkiTaskID = 1
Public Const pgkiName = 2
Public Const pgkiEnabled = 3
Public Const pgkiScheduledStart = 4
Public Const pgkiDuration = 5
Public Const pgkiDelta = 6
Public Const pgkiAboutToEnd = 7
Public Const pgkiJustInTime = 8
Public Const pgkiDelayed = 9
Public Const pgkiFinished = 10
' others
Public Const pgksN = "N"
Public Const pgksY = "Y"

' constants
' procedures
Const gksProcNames = "X OnTimeScheduledStart OnTimeAboutToEnd OnTimeJustInTime OnTimeDelayed"
Const gksProcColumns = "X 4 7 8 9"
Const gksProcUpdates = "X N Y Y Y"
Const gkiProcScheduledStart = 1
Const gkiProcAboutToEnd = 2
Const gkiProcJustInTime = 3
Const gkiProcDelayed = 4
' colors
Const gklColorIndexNone = xlColorIndexNone
Const gklColorMissed = vbMagenta
Const gklColorScheduledStart = vbCyan
Const gklColorAboutToEnd = vbGreen
Const gklColorJustInTime = vbYellow
Const gklColorDelayed = vbRed
' passwords
Const gksPasswordWS = ""
Const gksPasswordWB = ""

' public declarations
' ranges
Public pgRngTask As Range

' declarations
' arrays
Dim gsProcName() As String, gsProcColumn() As String, gsProcUpdate() As String
Dim giTasks As Integer, glRow() As Long, giProcedure() As Integer, gdTime() As Date
' others
Dim gbOnOff As Boolean

Sub TrackingStart()
' constants
' declarations
Dim I As Long
' start
' application
Application.EnableEvents = False
' protection
ProtectWS False
' range
Set pgRngTask = ActiveSheet.Range(pgksTask)
' arrays
gsProcName = Split(gksProcNames)
gsProcColumn = Split(gksProcColumns)
gsProcUpdate = Split(gksProcUpdates)
' variables
giTasks = 0
gbOnOff = True
ActiveSheet.Range(pgksParamOnOff).Cells(1, 1).Value = gbOnOff
' process
With pgRngTask
For I = 1 To .Rows.Count
If .Cells(I, pgkiEnabled).Value = pgksY Then
TrackingStartNew I
End If
Next I
End With
' end
' range
Set pgRngTask = Nothing
' protection
ProtectWS True
' application
Application.EnableEvents = True
End Sub

Sub TrackingStartNew(plTableRow As Long)
' constants
' declarations
' start
Set pgRngTask = ActiveSheet.Range(pgksTask)
' process
With pgRngTask
If .Cells(plTableRow, pgkiEnabled).Value = pgksY Then
TrackingSchedule plTableRow, gkiProcScheduledStart
TrackingSchedule plTableRow, gkiProcAboutToEnd
TrackingSchedule plTableRow, gkiProcJustInTime
TrackingSchedule plTableRow, gkiProcDelayed
End If
End With
' end
End Sub

Sub TrackingSchedule(plTableRow As Long, piProcedure As Integer)
' constants
' declarations
Dim I As Integer, dNow As Date, dOriginal As Date, dAdded As Date
' start
dNow = Now()
' process
With pgRngTask
If .Cells(plTableRow, Val(gsProcColumn(piProcedure))).Interior.ColorIndex = _
gklColorIndexNone Then
' particular times
Select Case piProcedure
Case gkiProcScheduledStart
I = 0
dAdded = 0
Case gkiProcAboutToEnd
I = -1
dAdded = .Cells(plTableRow, pgkiDuration).Value
Case gkiProcJustInTime
I = 0
dAdded = .Cells(plTableRow, pgkiDuration).Value
Case gkiProcDelayed
I = 1
dAdded = .Cells(plTableRow, pgkiDuration).Value
Case Else
I = 0
dAdded = 0
End Select
' original time
dOriginal = .Cells(plTableRow, pgkiScheduledStart).Value + dAdded
' new?
If dNow <= dOriginal + I * .Cells(plTableRow, pgkiDelta).Value Then
' redims
giTasks = giTasks + 1
ReDim Preserve glRow(giTasks), giProcedure(giTasks), gdTime(giTasks)
' new array entries
glRow(giTasks) = plTableRow
giProcedure(giTasks) = piProcedure
gdTime(giTasks) = dOriginal + I * .Cells(plTableRow, pgkiDelta).Value
' add schedule
Application.OnTime _
gdTime(giTasks), gsProcName(giProcedure(giTasks)), , True
Debug.Print plTableRow; Val(gsProcColumn(piProcedure)); piProcedure, gdTime(giTasks), gsProcName(giProcedure(giTasks))
' cell (i)
With .Cells(plTableRow, Val(gsProcColumn(piProcedure)))
' clear value
If .Cells(plTableRow, Val(gsProcColumn(piProcedure))).Value = "" Then
If gsProcUpdate(piProcedure) = pgksY Then .Value = ""
End If
End With
' cells task
.Cells(plTableRow, pgkiTaskID).Interior.ColorIndex = gklColorIndexNone
.Cells(plTableRow, pgkiName).Interior.ColorIndex = gklColorIndexNone
Else
' cell (i)
With .Cells(plTableRow, Val(gsProcColumn(piProcedure)))
' color missed
.Interior.Color = gklColorMissed
' set value
If .Cells(plTableRow, Val(gsProcColumn(piProcedure))).Value = "" Then
If gsProcUpdate(piProcedure) = pgksY Then .Value = dOriginal
End If
End With
' cells task
.Cells(plTableRow, pgkiTaskID).Interior.Color = gklColorMissed
.Cells(plTableRow, pgkiName).Interior.Color = gklColorMissed
End If
End If
End With
' end
End Sub

Sub TrackingEndOld(plTableRow As Long)
' constants
' declarations
Dim I As Integer
' start
' process
For I = giTasks To 1 Step -1
If glRow(I) = plTableRow Then
TrackingDeprogram plTableRow, I
End If
Next I
' end
End Sub

Sub TrackingDeprogram(plTableRow As Long, piTask As Integer)
' constants
' declarations
Dim I As Integer, J As Integer
' start
On Error Resume Next
' process
With pgRngTask
' delete schedule
Application.OnTime _
gdTime(piTask), gsProcName(giProcedure(piTask)), , False
Debug.Print -plTableRow; Val(gsProcColumn(giProcedure(piTask))); giProcedure(piTask), gdTime(piTask), gsProcName(giProcedure(piTask))
' shift array entries
For I = piTask + 1 To giTasks
glRow(I - 1) = glRow(I)
giProcedure(I - 1) = giProcedure(I)
gdTime(I - 1) = gdTime(I)
Next I
' redims
giTasks = giTasks - 1
ReDim Preserve glRow(giTasks), giProcedure(giTasks), gdTime(giTasks)
End With
' end
On Error GoTo 0
End Sub

Sub TrackingStop()
' constants
' declarations
Dim I As Integer
' start
' application
Application.EnableEvents = False
' protection
ProtectWS False
' error
On Error Resume Next
' process
For I = 1 To giTasks
If gdTime(I) < Now() Then _
Application.OnTime gdTime(I), gsProcName(giProcedure(I)), , False
Next I
' end
' variables
ReDim glRow(0), giProcedure(0), gdTime(0)
gbOnOff = False
ActiveSheet.Range(pgksParamOnOff).Cells(1, 1).Value = gbOnOff
' error
On Error GoTo 0
' protection
ProtectWS True
' application
Application.EnableEvents = True
End Sub

Sub TrackingView()
' constants
Const kdDateTime = "ddd dd/mm/yyyy hh:mm:ss"
Const kiProcedure = 25
' declarations
Dim I As Integer, A As String, D As Date
' start
D = Now()
A = Format(D, kdDateTime) & " - " & gbOnOff & " - " & giTasks & " tasks" & vbCr
' process
For I = 1 To giTasks
If gdTime(I) >= Now() Then
A = A & vbCr
A = A & "#" & I & " - " & _
"Lin: " & glRow(I) & " - " & _
"At: " & Format(gdTime(I), kdDateTime) & " - " & _
"Proc: " & gsProcName(giProcedure(I))
End If
Next I
' end
MsgBox A, vbInformation + vbOKOnly, "Scheduled trackings"
End Sub

Sub TrackingReset()
' constants
' declarations
' start
' go?
If gbOnOff Then Exit Sub
' application
Application.EnableEvents = False
' protection
ProtectWS False
' range
Set pgRngTask = ActiveSheet.Range(pgksTask)
' variable
ActiveSheet.Range(pgksParamOnOff).Cells(1, 1).Value = gbOnOff
' process
With pgRngTask
If .Rows.Columns.Count > 1 Then
' color
With Application.Union(.Columns(pgkiTaskID), _
.Columns(pgkiName), _
.Columns(pgkiScheduledStart))
.Interior.ColorIndex = gklColorIndexNone
End With
' value and color
With Application.Union(.Columns(pgkiAboutToEnd), _
.Columns(pgkiJustInTime), _
.Columns(pgkiDelayed), _
.Columns(pgkiFinished))
.ClearContents
.Interior.ColorIndex = gklColorIndexNone
End With
End If
End With
' end
' variables
ReDim glRow(0), giProcedure(0), gdTime(0)
' range
Set pgRngTask = Nothing
' protection
ProtectWS True
' application
Application.EnableEvents = True
End Sub

Sub TrackingEnable(pbEnable As Boolean)
' constants
' declarations
Dim sYN As String
' start
' application
Application.EnableEvents = False
' protection
ProtectWS False
' range
Set pgRngTask = ActiveSheet.Range(pgksTask)
' variable
If pbEnable Then sYN = pgksY Else sYN = pgksN
' process
With pgRngTask.Columns(pgkiEnabled)
.Cells = sYN
End With
' end
' range
Set pgRngTask = Nothing
' protection
ProtectWS True
' application
Application.EnableEvents = True
End Sub

Sub OnTimeScheduledStart()
' constants
' declarations
' start
' process
OnTimeAnything gkiProcScheduledStart
' end
End Sub

Sub OnTimeAboutToEnd()
' constants
' declarations
' start
' process
OnTimeAnything gkiProcAboutToEnd
' end
End Sub

Sub OnTimeJustInTime()
' constants
' declarations
' start
' process
OnTimeAnything gkiProcJustInTime
' end
End Sub

Sub OnTimeDelayed()
' constants
' declarations
' start
' process
OnTimeAnything gkiProcDelayed
' end
End Sub

Private Sub OnTimeAnything(piProcedure As Integer)
' constants
Const kdLagTime = #12:00:05 AM#
' declarations
Dim I As Long, dNow As Date, lColor As Long
' start
' application
Application.EnableEvents = False
' protection
ProtectWS False
' range
Set pgRngTask = ActiveSheet.Range(pgksTask)
' variable
dNow = Now()
' process
For I = 1 To giTasks
If giProcedure(I) = piProcedure And Abs(dNow - gdTime(I)) < kdLagTime Then
With pgRngTask
If Not IsDate(.Cells(glRow(I), pgkiFinished).Value) Then
' color
Select Case piProcedure
Case gkiProcScheduledStart
lColor = gklColorScheduledStart
Case gkiProcAboutToEnd
lColor = gklColorAboutToEnd
Case gkiProcJustInTime
lColor = gklColorJustInTime
Case gkiProcDelayed
lColor = gklColorDelayed
End Select
' cell (i)
With .Cells(glRow(I), Val(gsProcColumn(piProcedure)))
' color
.Interior.Color = lColor
' value
If .Cells(glRow(I), Val(gsProcColumn(piProcedure))).Value = "" Then
If gsProcUpdate(piProcedure) = pgksY Then .Value = gdTime(I)
End If
End With
' cells task
.Cells(glRow(I), pgkiTaskID).Interior.Color = lColor
.Cells(glRow(I), pgkiName).Interior.Color = lColor
End If
End With
End If
Next I
' end
' range
Set pgRngTask = Nothing
' protection
ProtectWS True
' application
Application.EnableEvents = True
End Sub

Sub ProtectWS(pbProtect As Boolean)
' constants
' declarations
' start
' process
With ActiveSheet
If pbProtect Then
.Protect Password:=gksPasswordWS, _
DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
Else
.Unprotect gksPasswordWS
End If
End With
' end
End Sub

Sub ProtectWB(pbProtect As Boolean)
' constants
' declarations
' start
' process
With ActiveWorkbook
If pbProtect Then
.Protect Password:=gksPasswordWB, Structure:=True, Windows:=False
Else
.Unprotect gksPasswordWB
End If
End With
' end
End Sub

-----


Worksheet layout (Columns A:K):

-----

Task ID

Name

Enabled

Scheduled start

Duration

Δ time

About to end (Scheduled + Duration - Δ time)

Just in time (Scheduled + Duration)

Delayed (Scheduled + Duration + Δ time)

Finished

…

-----


6 command buttons calling homonyms procedures:

Start tracking

Stop tracking

Tracking view

Reset tracking

Enable all

Disable all


2 named ranges:

ParamOnOff: =$A$1

TaskTable: dynamic range from $A$2 across and down
>
Hope it helps. Just advise if any issue.


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