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

Michael

New member
Joined
Oct 25, 2011
Messages
1
Reaction score
0
Points
0
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?
 

maninweb

New member
Joined
Mar 22, 2011
Messages
88
Reaction score
0
Points
0
Location
Germany
Website
excel-translator.de
Excel Version(s)
2010, 2016, 2016 Insider
Hi Michael...

please try the code below, and please note that I have not tested all cases. You can use and may adapt the function in following ways...

  • If you pass a race name to the function, the only the passed races will be highlighted, Example GetHighestTimes("RaceA") or GetHighestTimes("RaceA,RaceB")
  • The constants are defining where the Range used in my sheet is located, here in my case it is B2:C7, so you may adapt this to your sheet
  • You may also adapt the sheet name, which is in my case "Sheet1"
  • I used two color indexes for highlighting the cells background, of course you can also adapt this.
Finally, if the solution works for you, it will be great, if you inform the other forum, that a solution was found.

Regards :)

Code:
  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
 

Zack Barresse

Super Moderator
Staff member
Joined
Mar 16, 2011
Messages
112
Reaction score
0
Points
0
Location
Oregon, United States
Excel Version(s)
365, Online, iOS, iOS for iPad
If you don't have duplicates, you can use something like this...

Code:
Sub GetMax2()

    Dim rMax1 As Range, rMax2 As Range
    Dim iMax1 As Double, iMax2 As Variant, iRow As Variant
    Dim sRange1 As String, sRange2 As String
    
    Const sRangeCheck As String = "A2:A"
    Const sRangeValues As String = "B2:B"
    Const sCheck As String = "RaceA"
    
    iRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    
    sRange1 = sRangeCheck & iRow
    sRange2 = sRangeValues & iRow
    
    iMax1 = Application.Evaluate("=MAX(IF(" & sRange1 & "=""" & sCheck & """," & sRange2 & "))")
    iMax2 = Application.Evaluate("=MAX(IF((" & sRange1 & "=""" & sCheck & """)*(" & sRange2 & "<>" & iMax1 & ")," & sRange2 & "))")
    
    Set rMax1 = ActiveSheet.Range(sRange2).Find(iMax1)
    Set rMax2 = ActiveSheet.Range(sRange2).Find(iMax2)
    
    rMax1.Interior.ColorIndex = 3
    rMax2.Interior.ColorIndex = 4
    
End Sub

HTH
 
Top