VBA code to find highest and 2nd highest number based in criteria

**Michael007** · 10-25-2011, 02:38 AM

Please note firstly I've post this on different forum but didn't get any solution after many hours of waiting, so can someone help me out here please. Where I've posted: here and here and here

Problem:
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
I need the vba sub instead of worksheet function.
Can anyone help pls?

**Michael007** · 10-25-2011, 06:28 AM

What I've done so far:

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

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 !

**arlu1201** · 10-25-2011, 07:00 AM

Try this code - Green color for 1st highest, Yellow for 2nd highest. The concept here is that you sort the data on the basis of Race # as well as the timings from smallest to largest. This way, the 1st 2 numbers will always be the 1st and 2nd highest respectively.

Sub compare_time()

Columns("A:B").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A:A"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B:B"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:B")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

lastrow = Range("A1").End(xlDown).Row
firsthigh = 0
sechigh = 0

For i = 2 To lastrow

    If Range("A" & i).Value = Range("A" & i + 1).Value Then
    
        If Range("B" & i).Value < Range("B" & i + 1).Value Then
                    
            If firsthigh < Range("B" & i).Value And firsthigh = 0 Then
                
                firsthigh = Range("B" & i).Value
                Range("B" & i).Select
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 5287936
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            
                sechigh = Range("B" & i + 1).Value
                Range("B" & i + 1).Select
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                
            End If
               
        End If
                
    ElseIf Range("A" & i).Value <> "" And Range("A" & i + 1).Value = "" Then
    
        firsthigh = Range("B" & i).Value
        Range("B" & i).Select
        With Selection.Interior
              .Pattern = xlSolid
              .PatternColorIndex = xlAutomatic
              .Color = 5287936
              .TintAndShade = 0
              .PatternTintAndShade = 0
        End With
            
        sechigh = 0
    
    Else
    
        firsthigh = 0
        sechigh = 0
        
    End If
        
Next

End Sub

**Michael007** · 10-25-2011, 07:16 AM

Hi thanks for the code. I tried to run it just now and it does work. But I've seen that you have also sorted RaceB, however I only want RaceA to be sorted and is there a way I can add a 3rd highest time?

As you can see from the attachment, I've attach my worksheet
Sorry if I didn't made it clear at start

**Michael007** · 10-25-2011, 07:40 AM

Also I'll attach the worksheet after I run the macro, as you can see in the worksheet, the fastest time should be 62.88 but instead it highlights 63.496

**arlu1201** · 10-25-2011, 08:38 AM

In the example in your first post, you should have specified all the columns. Change the code as follows - (You have changed most of it)

Sub compare_time()

Columns("A:G").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B:B"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G:G"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:G")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

lastrow = Range("A1").End(xlDown).Row
firsthigh = 0
sechigh = 0

For i = 2 To lastrow

    If Range("B" & i).Value = Range("B" & i + 1).Value Then
    
        If Range("G" & i).Value < Range("G" & i + 1).Value Then
                    
            If firsthigh < Range("G" & i).Value And firsthigh = 0 Then
                
                firsthigh = Range("G" & i).Value
                Range("G" & i).Select
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 5287936
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            
                sechigh = Range("G" & i + 1).Value
                Range("G" & i + 1).Select
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
                
            End If
               
        End If
                
    ElseIf Range("B" & i).Value <> "" And Range("B" & i + 1).Value = "" Then
    
        firsthigh = Range("G" & i).Value
        Range("G" & i).Select
        With Selection.Interior
              .Pattern = xlSolid
              .PatternColorIndex = xlAutomatic
              .Color = 5287936
              .TintAndShade = 0
              .PatternTintAndShade = 0
        End With
            
        sechigh = 0
    
    Else
    
        firsthigh = 0
        sechigh = 0
        
    End If
        
Next

End Sub