How Can I Program Excel to Run Like a Stopwatch
DA Honeycutt
I would like to use Excel to record lap times at a race track. Maybe
push F1 or other button every time a car passes and record on a
spreadsheet every lap time. Any suggestions?
Thanks,
David
Ralph Brown
DA Honeycutt wrote in message <34917399...@vnet.net>...
>I would like to use Excel to record lap times at a race track. Maybe
>push F1 or other button every time a car passes and record on a
>spreadsheet every lap time. Any suggestions?
This intrigued me so I wrote a version which follows. To use it, put it in
the worksheet project - get to it from Tools->Macros->VisualBasic and click
on the sheet you want it attached to.
It works by right clicking in the column you want to have the times in
anywhere that there are previous times. It builds a column of lap times with
the total time in red as the last entry, the lap times in black. All times
are in seconds with 2 decimals. I'm not sure how accurate it is, but it's
not ridiculous. To start a new column, right click in the first cell you
want a number to appear in, it starts with the total time since the start.
To reset the start date, use the ResetTime macro.
Option Explicit
Private Type SYSTEMTIME ' Win32 API structure to get
accurate time
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private startDate As Date ' first time seen
Private startMs As Integer ' and msec
Private initFlag As Boolean ' have we done this
yet?
' This is called when a right click is done in the worksheet it is attached
to
' it looks at the column it is in for either a cell which doesn't have a
number, or
' the red number. It then calls the DoTime routine
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel
As Boolean)
Dim endCell As Range
Cancel = True ' no menu
Set endCell = Target
While IsNumeric(endCell.Text)
If (endCell.Font.ColorIndex = 3) Then ' is this the
total elasped time cell?
DoTime endCell ' yes, do it
Exit Sub ' that's all
folks
End If
Set endCell = endCell.Offset(1, 0) ' not this
one search down
Wend
DoTime endCell ' must be a new column
End Sub
' This actually fills in the cells. It replaces the cell passed in with the
lap time
' which is in black, and puts the total time from the start in the next cell
down in red. If
' the cell passed in isn't a number, it assumes it is a column that hasn't
been used and saves
' the total time from the start in both cells
Private Sub DoTime(Target As Range)
Dim newTime As SYSTEMTIME ' the current time
Dim newDate As Date ' and current time as
date
Dim oldSeconds As Double ' last time as a seconds
from startDate
Dim newSeconds As Double ' current time from
startDate
Dim diffSeconds As Double ' seconds since last
Dim cellText As String ' text from the target
GetLocalTime newTime ' get the time for msec
With newTime
newDate = DateSerial(.wYear, .wMonth, .wDay) + _
CDate(CStr(.wHour) & ":" & CStr(.wMinute) & ":" &
CStr(.wSecond)) ' and date
End With
If (initFlag) Then ' ever inited
startDate = newDate ' save the start point
startMs = newTime.wMilliseconds
initFlag = False ' done it now
newSeconds = 0
diffSeconds = 0
Else ' we've done this before
newSeconds = CDbl(DateDiff("s", startDate, newDate)) + _
CDbl(newTime.wMilliseconds) / 1000 ' new
time in seconds
cellText = Trim(Target.Text) ' get previous
time
If (IsNumeric(cellText)) Then ' make sure
this is a real time
oldSeconds = CDbl(cellText) ' get it
diffSeconds = newSeconds - oldSeconds '
lap time
Else
diffSeconds = newSeconds ' save when
it started
End If
End If
Target.NumberFormat = "0.00" ' show at least one sec value
Target.Font.ColorIndex = xlColorIndexAutomatic ' normal color
Target.Value = diffSeconds ' replace target with lap
time
Target.Offset(1, 0).NumberFormat = "0.00" ' show at least
one sec value
Target.Offset(1, 0).Font.ColorIndex = 3 ' red color
Target.Offset(1, 0) = newSeconds ' save seconds from
start
Target.Offset(1, 0).Select ' move down
End Sub
' This resets the init flag to do something like a restart
' This really doesn't have to be called
Public Sub ResetTime()
initFlag = True
End Sub