Recording competitor times in mm:ss.00 help with VBA code

epasccm

New Member
Joined
Aug 3, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi I am reasonably inexperienced with complex excel issues.
I am a member of a motorsport club who has an upcoming event on saturday (yes only in a few days time!!) and I have a spreadsheet that isn't doing what I need it to, to record our competitors times!
The format of the event it that there are 3 tracks and each of the 30 drivers have 3 goes at each track. Only their fast time from each track gets added together to come up with their total score.
My current spreadsheet did work perfectly if I only needed to account for minutes and seconds but I really need it to include the hundredth's of a second (mm:ss.00)

I had a go at VBA (for the first time - didn't know this existed) using a code I found while searching the internet and it was working (but for some unknown reason it no longer is?????)

This was the code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Intrsct As Range, Cell As Range, s As String
Dim mins As Long, secs As Long, t As Date

Set Intrsct = Intersect(Range("I6:J35,L6:M35,O6:P35,S6:T35,V6:W35,Y6:Z35,AC6:AD35,AF6:AG35,AI6:AJ35,AM6:AN35,AP6:AQ35,AS6:AT35"), Target)
If Intrsct Is Nothing Then Exit Sub

Application.EnableEvents = False
For Each Cell In Intrsct
s = Cell.Text
If s = "" Then
Cell.NumberFormat = "@"
ElseIf Len(s) > 4 Then
Cell.Clear
Cell.NumberFormat = "@"
Else
s = Right("0000" & s, 4)
If s Like "####" Then
mins = CLng(Left(s, 2))
secs = CLng(Right(s, 2))
t = TimeSerial(0, mins, secs)
Cell.NumberFormat = "[mm]:ss"
Cell.Value = t
Else
Cell.Clear
Cell.NumberFormat = "@"
End If
End If
Next Cell
Application.EnableEvents = True
End Sub

But like I said it didn't work for hundredth's of a second.

Question 1: can this be modified to include hundredth's of a second, mm:ss.00 if so please show me how.
Question 2: is there a completely better way?
Question 3: why did it stop working today when every other time I have opened the spreadsheet it was fine - is there a setting that I need to change?
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Can you post a copy of your data using the XL2BB tool? See signature for instructions.
 
Upvote 0
Question 1: can this be modified to include hundredth's of a second, mm:ss.00 if so please show me how.
Yes, I modified the number format so that it will include hundredths and expanded the lines "ElseIf Len(s) > 6 Then" and "s = Right("000000" & s, 6)" from 4 to 6 and changed "If s Like "######" Then" to include two more digits

Question 2: is there a completely better way?
I hope the code below is better. I removed the Loop and replaced the Cell variable with Target since you are only ever changing one cell which is the Target despite the loop. (i.e. the loop only fires once if Intrsct is not nothing)
Question 3: why did it stop working today when every other time I have opened the spreadsheet it was fine - is there a setting that I need to change?
Is it possible that you encountered an issue somewhere along the way and stopped the execution of the macro before it ended? If so, the Application.EnableEvents is still set to FALSE. You can run the code below to fix that.

Code to turn on Events
VBA Code:
Sub x()
Application.EnableEvents = True
End Sub

Revised Code for hundredths
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Intrsct As Range, Cell As Range, s As String
    Dim mins As String, secs As String
    
    Set Intrsct = Intersect(Range("I6:J35,L6:M35,O6:P35,S6:T35,V6:W35,Y6:Z35,AC6:AD35,AF6:AG35,AI6:AJ35,AM6:AN35,AP6:AQ35,AS6:AT35"), Target)
    
    If Intrsct Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    For Each Cell In Intrsct
        s = Cell.Text
        If s = "" Then
            Cell.NumberFormat = "@"
        ElseIf Len(s) > 6 Then
            Cell.Clear
            Cell.NumberFormat = "@"
        Else
            s = Right("000000" & s, 6)
            If s Like "######" Then
                mins = Left(s, 2)
                secs = Mid(s, 3, 2) & "." & Right(s, 2)
                Cell.NumberFormat = "[mm]:ss.00"
                Cell.Value = mins & ":" & secs
            Else
                Cell.Clear
                Cell.NumberFormat = "@"
            End If
        End If
    Next Cell
    
    Application.EnableEvents = True
    
End Sub
 
Upvote 0
example.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAK
1
2
3Test 1Test 2Test 3
4Run 1Run 2Run 3Run 1Run 2Run 3Run 1Run 2Run 3
5#NameTOTALTest 1Test 2Test 3Test 4TimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotalTimePenaltyTotal
61driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
72driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
83driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
94driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
105driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
116driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
127driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
138driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
149driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
1510driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
1611driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
1712driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
1813driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
1914driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2015driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2116driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2217driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2318driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2419driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2520driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2621driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2722driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2823driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
2924driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3025driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3126driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3227driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3328driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3429driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
3530driver name00:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:0000:00
36
37Slowest timesTest 100:00Test 100:00Test 100:00
Timesheet
Cell Formulas
RangeFormula
C6:C35C6=SUM(D6:G6)
D6:D35D6=MINA(K6,N6,Q6)
E6:E35E6=MINA(U6,X6,AA6)
F6:F35F6=MINA(AE6,AH6,AK6)
G6:G35G6=MINA(AO6,AR6,AU6)
AK6:AK35,AH6:AH35,AE6:AE35,AA6:AA35,X6:X35,U6:U35,Q6:Q35,N6:N35,K6:K35K6=SUMPRODUCT(I6+J6)
L37,AF37,V37L37=MAXA(I6:I35,L6:L35,O6:O35)
 
Upvote 0
Yes, I modified the number format so that it will include hundredths and expanded the lines "ElseIf Len(s) > 6 Then" and "s = Right("000000" & s, 6)" from 4 to 6 and changed "If s Like "######" Then" to include two more digits


I hope the code below is better. I removed the Loop and replaced the Cell variable with Target since you are only ever changing one cell which is the Target despite the loop. (i.e. the loop only fires once if Intrsct is not nothing)

Is it possible that you encountered an issue somewhere along the way and stopped the execution of the macro before it ended? If so, the Application.EnableEvents is still set to FALSE. You can run the code below to fix that.

Code to turn on Events
VBA Code:
Sub x()
Application.EnableEvents = True
End Sub

Revised Code for hundredths
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Intrsct As Range, Cell As Range, s As String
    Dim mins As String, secs As String
   
    Set Intrsct = Intersect(Range("I6:J35,L6:M35,O6:P35,S6:T35,V6:W35,Y6:Z35,AC6:AD35,AF6:AG35,AI6:AJ35,AM6:AN35,AP6:AQ35,AS6:AT35"), Target)
   
    If Intrsct Is Nothing Then Exit Sub
   
    Application.EnableEvents = False
   
    For Each Cell In Intrsct
        s = Cell.Text
        If s = "" Then
            Cell.NumberFormat = "@"
        ElseIf Len(s) > 6 Then
            Cell.Clear
            Cell.NumberFormat = "@"
        Else
            s = Right("000000" & s, 6)
            If s Like "######" Then
                mins = Left(s, 2)
                secs = Mid(s, 3, 2) & "." & Right(s, 2)
                Cell.NumberFormat = "[mm]:ss.00"
                Cell.Value = mins & ":" & secs
            Else
                Cell.Clear
                Cell.NumberFormat = "@"
            End If
        End If
    Next Cell
   
    Application.EnableEvents = True
   
End Sub
I have included your suggested changes as above but it doesn't seem to be working when I enter an amount in the cell. For example if I type 123456 I would like it to be 12:34.56 but it is such coming up as 123456. - any suggestions??? thanks for your time on this it is appreciated!
 
Upvote 0
I think you have to copy the code that i provided and use it and also you will have to run the macro below to re-enable the events

VBA Code:
Sub x()
Application.EnableEvents = True
End Sub
 
Upvote 0
With your data and my macro, I entered 123456 in I6 and got the following:

epasccm 20210804.xlsm
ABCDEFGHIJKLMNOPQ
1
2
3Test 1
4Run 1Run 2Run 3
5#NameTOTALTest 1Test 2Test 3Test 4TimePenaltyTotalTimePenaltyTotalTimePenaltyTotal
61driver name0000012:34.560.00873300
72driver name00000000
83driver name00000000
94driver name00000000
Sheet2
Cell Formulas
RangeFormula
C6:C9C6=SUM(D6:G6)
D6:D9D6=MINA(K6,N6,Q6)
E6:E9E6=MINA(U6,X6,AA6)
F6:F9F6=MINA(AE6,AH6,AK6)
G6:G9G6=MINA(AO6,AR6,AU6)
K6:K9,Q6:Q9,N6:N9K6=SUMPRODUCT(I6+J6)
 
Upvote 0
Sorry the code I posted above still included the loop but that is the only difference. Here is the code with the loop taken out since it really doesn't do anything.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Intrsct As Range, s As String
    Dim mins As String, secs As String
    
    Set Intrsct = Intersect(Range("I6:J35,L6:M35,O6:P35,S6:T35,V6:W35,Y6:Z35,AC6:AD35,AF6:AG35,AI6:AJ35,AM6:AN35,AP6:AQ35,AS6:AT35"), Target)
    
    If Intrsct Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    s = Target.Text
    If s = "" Then
        Target.NumberFormat = "@"
    ElseIf Len(s) > 6 Then
        Target.Clear
        Target.NumberFormat = "@"
    Else
        s = Right("000000" & s, 6)
        If s Like "######" Then
            mins = Left(s, 2)
            secs = Mid(s, 3, 2) & "." & Right(s, 2)
            Target.NumberFormat = "[mm]:ss.00"
            Target.Value = mins & ":" & secs
        Else
            Target.Clear
            Target.NumberFormat = "@"
        End If
    End If
    
    Application.EnableEvents = True
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top