Option Explicit
Private Const cstStartRow As Long = 3 ' The used Row where the first entry is, RaceA, 4.5
Private Const cstStartCol As Long = 2 ' The used Column where the first entry is, RaceA, 4.5
Private Const cstColorFirst As Long = 44 ' The used color index for the first highest race
Private Const cstColorSecond As Long = 37 ' The used color index the second highest race
Public Sub GetHighestTimes(Races As String)
Dim lngCurrent As Long
Dim lngIndex As Long
Dim lngRows As Long
Dim dblValue As Double
Dim strRace As String
Dim objRaces As Collection
Dim dblRaces() As Double ' Race values
Dim lngRaces() As Long ' Race rows
' Disable errors...
On Error Resume Next
' Get the last row and subtract the start row, gives the rows used in the range...
lngRows = ThisWorkbook.Worksheets("Sheet1").Cells( _
ThisWorkbook.Worksheets("Sheet1").Rows.Count, _
cstStartCol).End(xlUp).Row - cstStartRow + 1
' Collection
Set objRaces = New Collection
' Redim, at least 2 races...
ReDim dblRaces(1 To 2, 1 To 2) As Double
ReDim lngRaces(1 To 2, 1 To 2) As Long
' You may adapt the sheet name...
With ThisWorkbook.Worksheets("Sheet1")
' Loop for getting data of all races...
For lngCurrent = cstStartRow To cstStartRow + lngRows - 1
' Current race, which will act as key for the collection...
strRace = Trim(.Cells(lngCurrent, cstStartCol).Value)
' Try to add the race to the collection
' Please note that duplicates normally leads to an error,
' however we have disabled errors, so the code goes on
'
' Check string passed to the function. If the string is empty then
' highlight the cells for all races, else hightlight only the passed race...
If Len(Races) > 0 Then
' Check if the race can be found in the passed string...
If InStr(1, UCase(Races), UCase(strRace)) > 0 Then
objRaces.Add CStr(objRaces.Count + 1), strRace
End If
Else
objRaces.Add CStr(objRaces.Count + 1), strRace
End If
' Clear...
Err.Clear
' Check array size...
If objRaces.Count > UBound(dblRaces, 1) Then
ReDim Preserve dblRaces(1 To objRaces.Count, 1 To 2) As Double
ReDim Preserve lngRaces(1 To objRaces.Count, 1 To 2) As Long
End If
' Index...
lngIndex = 0
lngIndex = objRaces(strRace)
' Check...
If lngIndex > 0 Then
' Read...
dblValue = CDbl(.Cells(lngCurrent, cstStartCol + 1).Value)
' Check if already used...
If lngRaces(lngIndex, 1) < 1 And lngRaces(lngIndex, 2) < 1 Then
dblRaces(lngIndex, 1) = dblValue
lngRaces(lngIndex, 1) = lngCurrent
Else
' Compare highest...
If dblRaces(lngIndex, 1) > dblValue Then
' Move and store...
dblRaces(lngIndex, 2) = dblRaces(lngIndex, 1)
dblRaces(lngIndex, 1) = dblValue
lngRaces(lngIndex, 2) = lngRaces(lngIndex, 1)
lngRaces(lngIndex, 1) = lngCurrent
Else
' Compare second...
If dblRaces(lngIndex, 2) > dblValue Then
lngRaces(lngIndex, 2) = dblValue
lngRaces(lngIndex, 2) = lngCurrent
End If
End If
End If
End If
Next lngCurrent
' Highlight races in the worksheet...
If objRaces.Count > 0 Then
' Loop...
For lngCurrent = 1 To objRaces.Count
' First highest race...
If lngRaces(lngCurrent, 1) > 0 Then
.Cells(lngRaces(lngCurrent, 1), cstStartCol + 1) _
.Interior.ColorIndex = cstColorFirst
End If
' Second highest race...
If lngRaces(lngCurrent, 2) > 0 Then
.Cells(lngRaces(lngCurrent, 2), cstStartCol + 1) _
.Interior.ColorIndex = cstColorSecond
End If
Next lngCurrent
End If
End With
End Sub
