Results 1 to 4 of 4

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

  1. #1

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

    Register for a FREE account, and/
    or Log in to avoid these ads!

    Note: I've already posted this in another forum:
    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?

  2. #2
    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 :-)

      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
              objRaces.Add CStr(objRaces.Count + 1), strRace
            End If
    '       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
    '           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
    '             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

  3. #3
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Nanaimo, BC, Canada
    Blog Entries
    Mourad, he's got answers at VBAX too...
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Master your data with Power Query: Purchase your copy of my book M is for Data Monkey today!

    Main Site: -||- Blog: -||- Forums:
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  4. #4
    Super Moderator Zack Barresse's Avatar
    Join Date
    Mar 2011
    Oregon, United States
    If you don't have duplicates, you can use something like this...

    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
    Zack Barresse

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts