Finding and ranking fastest times over several annual events

Brutality

Brutality

New Member
Joined
Feb 5, 2003
Messages
44
Hi,

It's been a while and I haven't used excel a lot of late so I'm more than a little rusty (although I still code) and now I'm trying to help automate a process for my father.

Each year he holds a car hill climb event, with 4 timed runs per competitor. What I would like to do is analyse all events and produce a report that outputs each drivers single best time (irrespective of car or year). Initially I had each event on a separate sheet, but have amalgamated all data, adding a year column. Data appears as so, up to 2017:

<style type="text/css"> body,div,table,thead,tbody,tfoot,tr,th,td,p { font-family:"Arial"; font-size:x-small } a.comment-indicator:hover + comment { background:#ffd; position:absolute; display:block; border:1px solid black; padding:0.5em; } a.comment-indicator { background:red; display:inline-block; border:1px solid black; width:0.5em; height:0.5em; } comment { display:none; } </style>
YEARNO.NAMECAR TYPERUN ONERUN TWORUN THREERUN FOUR
20061D ShanksAustin Healey34.8734.7134.8534.73
20062E HendersonJaguar MK234.8734.9333.2032.73
20063J McFadzienSinger Vogue40.7340.1039.9238.95
20067P RissellTR238.9538.9537.2436.98
20069B SheddanSunbeam Rapier38.3338.3337.4936.51
200610S QuertierV/8 Special32.5232.5231.2930.06
20071D ShanksAustin Healey34.6233.5533.2733.25
20072E HendersonJaguar MK232.9832.5832.4232.18
20074J McFadzienBMW 33.1032.5831.8831.00
20075D HarrisJohnstone FF27.0526.7426.3126.46
20076N AtleyBegg FF25.9725.5725.6525.46
20077B SheddanSunbeam Rapier35.6736.0437.2936.11
200710D McDonaldAlfa Romeo38.4631.2530.8831.01

<tbody>
</tbody>


And I want to produce something like the following, sorted by fastest to slowest time for every driver that has ever entered:

1E Henderson32.18Jaguar MK2Run Four2007
2D Shanks33.25Austin HealeyRun Four2007

<tbody>
</tbody>



On occasion some entries didn't complete all runs, so there are empty cells here and there. Originally I thought a pivot table might be the solution, but the more I investigate that option the more I think I'm wrong. Any ideas on how to achieve this as I really don't want to do it manually??


All help appreciated and TIA


--
Mark
 
Last edited:

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Try this for results on sheet2
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Oct48
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] Double, Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMin [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Run [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = Cells(1).CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 3)) [COLOR="Navy"]Then[/COLOR]
    oMin = 0
    oMax = Application.Max(Application.Index(Ray, n, Array(5, 6, 7, 8)))
    [COLOR="Navy"]For[/COLOR] Ac = 5 To 8
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Ray(n, Ac) < oMax [COLOR="Navy"]Then[/COLOR]
                oMin = Ray(n, Ac)
                oMax = oMin
                Run = Ray(1, Ac)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 3)) [COLOR="Navy"]Then[/COLOR]
            .Add Ray(n, 3), Array(Ray(n, 1), Ray(n, 4), Run, oMin)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Ray(n, 3))
                [COLOR="Navy"]If[/COLOR] oMin < Q(3) [COLOR="Navy"]Then[/COLOR]
                    Q(0) = Ray(n, 1): Q(1) = Ray(n, 4): Q(2) = Run: Q(3) = oMin
                [COLOR="Navy"]End[/COLOR] If
            .Item(Ray(n, 3)) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim nray(1 To .Count, 1 To 6)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    nray(c, 1) = c
    nray(c, 2) = K
    nray(c, 3) = .Item(K)(3)
    nray(c, 4) = .Item(K)(1)
    nray(c, 5) = .Item(K)(2)
    nray(c, 6) = .Item(K)(0)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A2").Resize(c, 6)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .Sort (.Parent.Range("C2"))
    .Parent.Range("A2").Resize(c).Sort (.Parent.Range("A2"))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick, that is great, thanks!

Just talked to my Dad and he has decided he wants the fastest times per individual for EACH car they might have run (over the years some entrants have entered different vehicles). Looking at your VB code I'm not sure how to make that happen. Could you help??

Sorry for the change in requirements and thanks again for a speedy answer.
 
Upvote 0
After spending a little time trying to understand the VB code (I was a Perl and PHP developer many years ago) I have what appears to be a working solution, although the output column order isn't what I want (that's next on the list but shouldn't be too difficult). Code only has minor changes:

Code: 
Sub GetFastestCarTimes()
Dim Rng As Range, Dn As Range, n As Long, oMax As Double, Ray As Variant, Ac As Long, oMin As Double
Dim Run As String, Q As Variant, K As Variant, c As Long
Ray = Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare


For n = 2 To UBound(Ray, 1)
    If Not IsEmpty(Ray(n, 3)) Then
    oMin = 0
    oMax = Application.Max(Application.Index(Ray, n, Array(5, 6, 7, 8)))
    For Ac = 5 To 8
       If Not IsEmpty(Ray(n, Ac)) Then
            If Ray(n, Ac) < oMax Then
                oMin = Ray(n, Ac)
                oMax = oMin
                Run = Ray(1, Ac)
            End If
        End If
        Next Ac
        If Not .Exists(Ray(n, 4)) Then
            .Add Ray(n, 4), Array(Ray(n, 1), Ray(n, 3), Run, oMin)
        Else
            Q = .Item(Ray(n, 4))
                If oMin < Q(3) Then
                    Q(0) = Ray(n, 1): Q(1) = Ray(n, 3): Q(2) = Run: Q(3) = oMin
                End If
            .Item(Ray(n, 4)) = Q
        End If
    End If
Next


ReDim nray(1 To .Count, 1 To 6)
For Each K In .keys
    c = c + 1
    nray(c, 1) = c
    nray(c, 2) = K
    nray(c, 3) = .Item(K)(3)
    nray(c, 4) = .Item(K)(1)
    nray(c, 5) = .Item(K)(2)
    nray(c, 6) = .Item(K)(0)
Next K
With Sheets("Fastest_times_cars").Range("A2").Resize(c, 6)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .Sort (.Parent.Range("C2"))
    .Parent.Range("A2").Resize(c).Sort (.Parent.Range("A2"))
End With
End With
End Sub
 
Upvote 0
OK I was wrong. Now it is only listing the single fastest time for a specific car model regardless of driver, as opposed to the fastest time per car per driver. Back to the drawing board.
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG06Oct38
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] Double, Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMin [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Run [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
Ray = Cells(1).CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 3)) [COLOR="Navy"]Then[/COLOR]
    Txt = Ray(n, 3) & "," & Ray(n, 4)
    oMin = 0
    oMax = Application.Max(Application.Index(Ray, n, Array(5, 6, 7, 8)))
    [COLOR="Navy"]For[/COLOR] Ac = 5 To 8
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Ray(n, Ac) < oMax [COLOR="Navy"]Then[/COLOR]
                oMin = Ray(n, Ac)
                oMax = oMin
                Run = Ray(1, Ac)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Array(Ray(n, 1), Ray(n, 4), Run, oMin)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Txt)
                [COLOR="Navy"]If[/COLOR] oMin < Q(3) [COLOR="Navy"]Then[/COLOR]
                    Q(0) = Ray(n, 1): Q(1) = Ray(n, 4): Q(2) = Run: Q(3) = oMin
                [COLOR="Navy"]End[/COLOR] If
            .Item(Txt) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim nray(1 To .Count, 1 To 6)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    nray(c, 1) = c
    nray(c, 2) = Split(K, ",")(0)
    nray(c, 3) = .Item(K)(3)
    nray(c, 4) = .Item(K)(1)
    nray(c, 5) = .Item(K)(2)
    nray(c, 6) = .Item(K)(0)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Fastest_times_cars").Range("A2").Resize(c, 6)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .Sort (.Parent.Range("C2"))
    .Parent.Range("A2").Resize(c).Sort (.Parent.Range("A2"))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Awesome, thanks Mick!

I did manage to get it working "acceptably" with some other added conditionals but it was messy and the layout was still wrong. Your solution is perfect, cheers.
 
Upvote 0
MickG said:
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG06Oct38
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] Double, Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMin [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Run [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
Ray = Cells(1).CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, 3)) [COLOR="Navy"]Then[/COLOR]
    Txt = Ray(n, 3) & "," & Ray(n, 4)
    oMin = 0
    oMax = Application.Max(Application.Index(Ray, n, Array(5, 6, 7, 8)))
    [COLOR="Navy"]For[/COLOR] Ac = 5 To 8
        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Ray(n, Ac) < oMax [COLOR="Navy"]Then[/COLOR]
                oMin = Ray(n, Ac)
                oMax = oMin
                Run = Ray(1, Ac)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Array(Ray(n, 1), Ray(n, 4), Run, oMin)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Txt)
                [COLOR="Navy"]If[/COLOR] oMin < Q(3) [COLOR="Navy"]Then[/COLOR]
                    Q(0) = Ray(n, 1): Q(1) = Ray(n, 4): Q(2) = Run: Q(3) = oMin
                [COLOR="Navy"]End[/COLOR] If
            .Item(Txt) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim nray(1 To .Count, 1 To 6)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    nray(c, 1) = c
    nray(c, 2) = Split(K, ",")(0)
    nray(c, 3) = .Item(K)(3)
    nray(c, 4) = .Item(K)(1)
    nray(c, 5) = .Item(K)(2)
    nray(c, 6) = .Item(K)(0)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Fastest_times_cars").Range("A2").Resize(c, 6)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
    .Sort (.Parent.Range("C2"))
    .Parent.Range("A2").Resize(c).Sort (.Parent.Range("A2"))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With
End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
Click to expand...

Mick, if you are still lurking on these boards (or anyone who can help) I have some new info and a request for help.

So the above code has worked flawlessly for several years worth of data, and it *still* works with a small caveat. This year one of the cars blew the clutch on its second run, so it only had one recorded time. When only one time exists, for whatever reason, it will take the empty value from RUN FOUR (the last data column) as 0.00 and use that as the fastest time (even though the field is empty). As soon as another dummy entry is added all is well. Tested on multiple enries to confirm. This isn't a problem since now that I am aware the issue is easily addressed, but it would be nice to get this one tiny glitch sorted.

TIA.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,215,092
Messages
6,123,064
Members
449,090
Latest member
fragment

Share this page

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