OK, Sam. I have had a chance to look at the workbook you posted on SkyDrive.
Looking at that workbook you provided, I don't see the problem. It certainly seems to me as if the lowest four entries for each time are being highlighted, with the special highlighting for the lowest. It is harder to see because of the way you have it sorted, but if you scroll down (or sort just by times), it seems as if the macro is working as designed.
Ron
Posting a followup here for this thread for completeness. Copies have already gone to Sam:
Having read your email I have now figured out what has gone wrong and it is not the macro as you rightly say, but it is a condition that wasnt known at the time the original macro was created.
What has happened is that this particular day is a rare ocassion when more than one race goes off at the same time..e.g the 13:40 at Ffos Las and the 13:40 Wincanton. Because this condition wasnt known to happen the macro rightly looks at the 1.40 combines all FC odds for that time span and picks the top 4 correctly.
Is it possible to amend the macro so that it looks at the time column and the course column before it selects the top four values in the FC odds column as this would ensure that this cannot happen? If it is a time consuming change please don't bother as I will find a way to work around it. I am just glad that with your help I have worked out what was happening !!
Being basically lazy, instead of rewriting the macro, I wrote a new macro (2 of them, actually).
They depend on several assumtions:
· Your column labels will always be in Row 1
· The "Time" column will always be labeled "Time"
· The "Course" column will always be labeled "Course"
· You will never use fractional seconds in determining the start time of the race.
Algorithm: Devise a list of the course names. For each course, add a defined amount of time (in 1/1000 of a second - limit of resolution) to the time so that each course, even though starting at the same time, will be different by 1/1000 of a second).
Then, when you run the Color4New2011 macro, it will differentiate the different race tracks.
When done, reset the times to remove the fractional seconds so nothing else gets affected.
=====================================
Option Explicit
Sub IncreaseTimes()
'indexes times to differentiate Courses
Dim rTimes As Range, rCourse As Range, c As Range
Dim colTimes As Long, colCourse As Long
Dim cCourses As Collection
Dim LastRow As Long
Dim i As Long
With WorksheetFunction
colTimes = .Match("Time", Range("$1:$1"), 0)
colCourse = .Match("Course", Range("$1:$1"), 0)
End With
LastRow = Cells(Rows.Count, 1).End(xlUp).row
Set rTimes = Range(Cells(2, colTimes), Cells(LastRow, colTimes))
Set rCourse = Range(Cells(2, colCourse), Cells(LastRow, colCourse))
'get list of courses
Set cCourses = New Collection
On Error Resume Next
For Each c In rCourse
cCourses.Add Item:=c.text, Key:=c.text
Next c
On Error GoTo 0
If cCourses.Count > 999 Then
MsgBox ("Too many courses" & vbLf & "Cannot have more than 999")
Exit Sub
End If
For i = 1 To cCourses.Count
For Each c In rTimes
If c.Offset(columnoffset:=rCourse.Column - rTimes.Column) = cCourses(i) Then
c.Value = c.Value + i / 86400000
End If
Next c
Next i
End Sub
Sub ResetTimes()
Dim rTimes As Range, c As Range
Set rTimes = Cells(2, WorksheetFunction.Match("Time", Range("$1:$1"), 0))
Set rTimes = Range(rTimes, Cells(Rows.Count, rTimes.Column).End(xlUp))
For Each c In rTimes
If IsNumeric(c.Value) Then
c.Value = CDate(c.Value)
End If
Next c
End Sub
'-----------------------------------------------------------------
Sub Color4New2011()
Dim rTimes As Range, rValues As Range, c As Range
Dim rCourse As Range
Const NumToColor As Long = 4
Dim APOffset() As Long
Dim tTimes() As Variant, dPVals() As Double
Dim collTime As Collection, collColQ As Collection
Dim bLowest As Boolean
Dim i As Long, j As Long, k As Long
On Error Resume Next
Set rTimes = Application.InputBox(Prompt:="Select the Times", _
Default:=Selection.Address, Type:=8)
If rTimes Is Nothing Then Exit Sub
Set rValues = Application.InputBox("Select One (1) cell in each column of Values ", Type:=8)
If rValues Is Nothing Then Exit Sub
On Error GoTo 0
'Make times unique to each track
ResetTimes 'just to be safe
IncreaseTimes
bLowest = IIf(MsgBox("Lowest " & NumToColor & "?", vbYesNo) = vbYes, True, False)
ReDim APOffset(0 To rValues.Count - 1)
i = 0
For Each c In rValues
APOffset(i) = c.Column - rTimes.Column
i = i + 1
Next c
'Unique list of times
Set collTime = New Collection
On Error Resume Next
For Each c In rTimes
collTime.Add Item:=c.Value, Key:=CStr(c.Value)
Next c
On Error GoTo 0
ReDim tTimes(0 To collTime.Count - 1, 0 To 2)
For i = 0 To collTime.Count - 1
tTimes(i, 0) = collTime(i + 1)
Next i
Application.ScreenUpdating = False
For k = 0 To UBound(APOffset)
'unique list of rValues values for each time
For i = 0 To UBound(tTimes, 1)
Set collColQ = New Collection
On Error Resume Next
For Each c In rTimes
If c.Value = tTimes(i, 0) Then
With c.Offset(columnoffset:=APOffset(k))
If bLowest = True Then collColQ.Add Item:=.Value, Key:=CStr(.text)
If bLowest = False And .Value <> 0 Then collColQ.Add Item:=.Value, Key:=CStr(.text)
End With
End If
Next c
On Error GoTo 0
If collColQ.Count > 0 Then
ReDim dPVals(0 To collColQ.Count - 1)
For j = 0 To UBound(dPVals)
dPVals(j) = collColQ(j + 1)
Next j
End If
With WorksheetFunction
If bLowest Then
tTimes(i, 1) = .Small(dPVals, .Min(UBound(dPVals) + 1, NumToColor))
tTimes(i, 2) = .Min(dPVals)
Else
tTimes(i, 1) = .Large(dPVals, .Min(UBound(dPVals) + 1, NumToColor))
tTimes(i, 2) = .Max(dPVals)
End If
End With
Next i
'color the cells
For i = 0 To UBound(tTimes, 1)
For Each c In rTimes
If c.Value = tTimes(i, 0) Then
With c.Offset(columnoffset:=APOffset(k))
If bLowest = False Then
'Select Case CDbl(.Text)
Select Case .Value
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
.Font.Color = vbRed
Case Is >= tTimes(i, 1)
.Interior.Color = vbGreen
.Font.Color = vbRed
Case Else
.Interior.Color = xlNone
.Font.Color = vbBlack
End Select
ElseIf bLowest = True Then
'Select Case CDbl(.Text)
Select Case .Value
Case Is = ""
.Interior.Color = xlNone
.Font.Color = vbBlack
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
.Font.Color = vbRed
Case Is <= tTimes(i, 1)
.Interior.Color = vbGreen
.Font.Color = vbRed
Case Else
.Interior.Color = xlNone
.Font.Color = vbBlack
End Select
End If
End With
End If
Next c
Next i
Next k
'reset times to baseline
ResetTimes
Application.ScreenUpdating = True
End Sub
===================================
