I need the VBA code to find the highest and 2nd highest value in a column based on criteria in another column. So for example:
Type | Time
RaceA| 4.5
RaceB| 5.5
RaceA| 6.2
RaceA| 3.1
RaceB| 2.1
I need the VBA code to be able to find the highest and 2nd highest Time for RaceA and highlight them in different color. So in the example above, the code should loop through the time based on Type and highlight 3.1 as highest and 4.5 as second highest
Can anyone help pls?
Greetings and welcome to vbaexpress Michael:hi:
Are ties possible, and if so, how to handle?
Thanks for replying. There won't be any ties in my data as all the Times are different
Can anyone help please? I need it urgently and couldnt find a solution
Not well tested, try:
[VBA]Option Explicit
Sub RateIt()
Dim rngRaceType As Range
Dim n As Long
Dim lCount As Long
Dim lRowStart As Long
With Sheet1 '<---COdename or ---> ThisWorkbook.Worksheets("Sheet1")
Set rngRaceType = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 4)
End With
With rngRaceType
.Columns(3).Formula = "=row()"
.Columns(3).Value = .Columns(3).Value
.Sort .Columns(1).Cells(1), xlAscending, , , , , , xlNo
lCount = 1
lRowStart = 1
For n = 2 To UBound(rngRaceType.Value, 1)
Do While rngRaceType.Cells(n, 1).Value = rngRaceType.Cells(n - 1, 1).Value _
And n <= UBound(rngRaceType.Value, 1)
lCount = lCount + 1
n = n + 1
Loop
rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 3).FormulaArray = _
"=RANK.EQ(" & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & _
"," & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & ",0)"
lCount = 1
lRowStart = n
Next
For n = 1 To UBound(rngRaceType.Value, 1)
If rngRaceType.Cells(n, 4).Value = 1 Then
rngRaceType.Cells(n, 1).Interior.ColorIndex = 4
ElseIf rngRaceType.Cells(n, 4).Value = 2 Then
rngRaceType.Cells(n, 1).Interior.ColorIndex = 6
End If
Next
.Columns(4).Clear
.Sort .Columns(3).Cells(1), xlAscending, , , , , , xlNo
.Columns(3).Clear
End With
End Sub[/VBA]
GTO thanks for the code, I've tried to run it but it gives an error saying Type mismatch on the line "If rngRaceType.Cells(n, 4).Value = 1 Then", do you know what might cause this error?
I got it working, just need to specify the worksheet. But now it does highlight the result but it highlights for RaceA 6.2 as the highest and 4.5 as second highest, but since it's a race time, the highest should be 3.1 instead of 6.2 because shorted time wins. Is there a way to change it?
Minimum not maximum
I've just notice another problem. The above code sort the Race type into ascending order, but I'm having other columns eg competitor name etc which has to be with the Race type and time, so I can't just sort the Race type into ascending order. And also I will be sorting the Time into ascending order aswell, so the above code won't work for me. What I have done so far is:[VBA]Sub Button1_Click()
Dim rfound As Range
Dim lCount As Long
Set rfound = Range("B1")
For lCount = 1 To WorksheetFunction.CountIf(Columns(2), "RaceA")
Set rfound = Columns(2).Find("RaceA", After:=rfound, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
With rfound
'code to search for the corresponding Time and then identify the ranking
End With
Next lCount
End Sub[/VBA]
However I'm unsure on how to search for the corresponding time for Race A, and then give it a ranking of 1st, 2nd and 3rd. Can someone please help !
Quote:
Originally Posted by Michaelk
Okay, it seems you got it working, I am assumed you changed to RANK?Quote:
Originally Posted by Michaelk
Oops! My bad on the order, of course low ET is likely to be the winner... Changing the last arg to -1 seems to work.
Code:rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 3).FormulaArray = _
"=RANK(" & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & _
"," & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & ",-1)"
No, it only temporarily sorts to put the race types (or heats?) together to use RANK on the now contiguous range. It may have seemed like the sort was permanent when the code broke, but if you follow it through, you'll see that we put some row numbers in a helper column first, so it can be sorted back at the end.Quote:
Originally Posted by Michaelk
You did not mention "...other columns..." before, which of course would be handy to know.:dunno If you reduce vbide and step through the code, you can see we now insert the helper columns, do the work, and delete the helper columns. Hopefully that won't glitch any formulas.
I see you are getting help elsewheres, but here is what I came up with:
In a Standard Module:
[VBA]Option Explicit
Sub RateIt_02()
Dim rngRaceType As Range
Dim n As Long
Dim lCount As Long
Dim lRowStart As Long
'// Ensure that activesheet is a real worksheet //
If TypeName(ActiveSheet) = "Worksheet" Then
If ActiveSheet.Type = xlWorksheet Then
With ActiveSheet
Set rngRaceType = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Else
Exit Sub
End If
Else
Exit Sub
End If
rngRaceType.Offset(, 2).Resize(, 2).Columns.EntireColumn.Insert xlShiftToRight
Set rngRaceType = rngRaceType.Resize(, 4)
With rngRaceType
.Columns(3).Formula = "=row()"
.Columns(3).Value = .Columns(3).Value
.Sort .Columns(1).Cells(1), xlAscending, , , , , , xlNo
lCount = 1
lRowStart = 1
For n = 2 To UBound(rngRaceType.Value, 1)
Do While rngRaceType.Cells(n, 1).Value = rngRaceType.Cells(n - 1, 1).Value _
And n <= UBound(rngRaceType.Value, 1)
lCount = lCount + 1
n = n + 1
Loop
rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 3).FormulaArray = _
"=RANK(" & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & _
"," & rngRaceType.Cells(lRowStart, 1).Resize(lCount).Offset(, 1).Address(0, 0) & ",-1)"
lCount = 1
lRowStart = n
Next
For n = 1 To UBound(rngRaceType.Value, 1)
If rngRaceType.Cells(n, 4).Value = 1 Then
rngRaceType.Cells(n, 1).Interior.ColorIndex = 4
ElseIf rngRaceType.Cells(n, 4).Value = 2 Then
rngRaceType.Cells(n, 1).Interior.ColorIndex = 6
End If
Next
'// Clear first, because of the array formula //
.Columns(4).Clear
.Sort .Columns(3).Cells(1), xlAscending, , , , , , xlNo
.Columns(3).Resize(, 2).EntireColumn.Delete
End With
End Sub[/VBA]
Thank you Aflatoon, I had only spotted one unanswered cross post.Quote:
Originally Posted by Aflatoon
Kind regards,
Mark