Time tracking

[frohanss]

I'm currently trying to create a VB code that can make a time tracking
sheet like this:

Start time - End time - Total time worked - Worker - Project - Date

All time values should be hh:mm:ss
Worker should be a value of 1 to 5 and project from 1 to 5.

I also whant to have each worker to have a short cutt like "Ctrl +A"
for project 1 and same worker has "Ctrl +S" for project 2 and so on.

Below is my work so far. (Start time - end time - total time - Date)
Working

Private Sub CommandButton1_Click()
Dim rgTimeInCell As Range, rgTimeOutCell As Range, rgWorked As Range
Dim r As Long

If Range("E1") = "" Then Range("E1") = Format(Date, "mmmm d, yyyy")
'Put date in cell E1 if empty
With ActiveSheet.PageSetup 'Put date in left footer if it is
empty
If .LeftFooter = "" Then .LeftFooter = Format(Date, "mmmm d,
yyyy")
End With
Set rgTimeInCell = Range("A65536").End(xlUp)
If Application.CountA(Range(rgTimeInCell, rgTimeInCell.Offset(0, 2))) =
3 Then _
Set rgTimeInCell = rgTimeInCell.Offset(1, 0) 'Go to the next row
Set rgTimeOutCell = rgTimeInCell.Offset(0, 1)
Set rgWorked = rgTimeInCell.Offset(0, 2)

If rgTimeInCell = 0 Then 'enter time in
rgTimeInCell = Now()
rgTimeInCell.NumberFormat = "hh:mm:ss"
Else 'time out
rgTimeOutCell = Now()
rgTimeOutCell.NumberFormat = "hh:mm:ss"
rgWorked.FormulaR1C1 = "=RoundUp(24 * Abs(RC[-1] - RC[-2]), 1)"
rgWorked = Application.Text((rgTimeOutCell - rgTimeInCell),
"h:mm:ss")
rgWorked.NumberFormat = "hh:mm:ss"
End If
End Sub

Can someone help me with the rest?

Regards