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

[MIchaelk]

Note: I've already posted this in another forum:http://www.vbaexpress.com/forum/showthread.php?t=39544

but after hours of waiting no one seem to have a solution, and I need this urgently, so can someone pls help:


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

Ps I only want the vba sub for the solution not the worksheet functions

Can anyone help pls?

 

[Hui]

If its urgent, Why not just sort by Column A and Column B

 

[MIchaelk]

Column A and B shouldnt change because it's connected to racers name and other columns. What I've done is sort the time in ascending order along with all the data, but I don't know how to find and highlight the highest and 2nd highest RaceA time

 

[NARAYANK991]

Hi ,


Hui has given the right option , but in case you insist on VBA , do you think this helps ?


Public Sub temp()

Start_Cell = "$C$2" 'Change this to the start address of the range in your worksheet

End_Cell = "$C$6" ' End address of your range

Range(Start_Cell).Select

Min_value = ActiveCell.Offset(0, 1).Value

Second_value = Min_value

ActiveCell.Offset(1, 0).Activate

Do Until ActiveCell.Address > End_Cell

If ActiveCell.Offset(0, 1).Value < Min_value Then

Second_value = Min_value

Min_value = ActiveCell.Offset(0, 1).Value

End If

ActiveCell.Offset(1, 0).Activate

Loop

MsgBox "The least value is " + Str(Min_value) + " and the second lowest value is " + Str(Second_value)

End Sub


Of course , the above assumes that you want the values for only one type !


Narayan

 

[MIchaelk]

NARAYANK991 thanks for your reply. I've tried your code with my worksheet, however the result I get are "The least value is 0 and the second lowest value is 0. But I don't have any 0's in the data. And by the way, I don't see any part of the code that refer to only find the highest and 2nd highest value for RaceA?

 

[NARAYANK991]

Hi Michael ,


I think the 0 comes because of a blank cell. I am not sure that my worksheet is having data on the same lines as yours ; I am giving below mine.


Type Time

RaceA 4.5

RaceB 5.5

RaceA 6.2

RaceA 3.1

RaceB 2.1


Narayan

 

[MIchaelk]

Hi What Ive done is this


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 !

 

[MIchaelk]

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


That's what I've done so far, 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 !

 

[Luke M]

I think this would be much easier to do using Conditional Formats, but for VB:

[pre]

Sub HighlightCells()
Dim Crit As String
Dim TopHigh As Range
Dim NextHigh As Range
Dim MyRange As Range

'Where is the criteria cell?
Crit = Range("D2").Value
'Where is range of cells to color/look at?
Set MyRange = Range("B2:B10")

'Randomly assign to 2 cells that contain text
Set TopHigh = Range("A1")
Set NextHigh = Range("B1")

For Each c In MyRange
'Remove previous coloring
c.Interior.ColorIndex = 0

If c.Offset(0, -1).Value = Crit And c.Value <> 0 Then
If c.Value < TopHigh.Value Then
Set NextHigh = TopHigh
Set TopHigh = c
ElseIf c.Value < NextHigh.Value Then
Set NextHigh = c
End If
End If
Next

'Color the cells, change as desired
TopHigh.Interior.ColorIndex = 3
NextHigh.Interior.ColorIndex = 6

End Sub

[/pre]