2

I have searched and found a code that extracts the top five names with the highest marks. The code is OK and I can get the names and marks

Sub Test_GetTopFive()
    GetTopFive Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
End Sub

Sub GetTopFive(r As Range)
    Dim v, t, i As Long
    t = Application.WorksheetFunction.Aggregate(14, 6, r.Columns(2), 5)
    v = r
    For i = 1 To UBound(v, 1)
        If Not IsError(v(i, 1)) Then
            If v(i, 2) >= t Then
                Debug.Print v(i, 1), v(i, 2)
            End If
        End If
    Next i
End Sub

But the results in the immediate window are not sorted. I need to get the names with the highest marks first.

YasserKhalil
  • 9,138
  • 7
  • 36
  • 95

3 Answers3

2

Have a go with the code below. The tricky part is you can't just sort arrays, So I instead have it loop the number of results you want, then for each of those it loops through the array to find the max value. Once found it prints it, then sets it's value to 0 to remove it from being looked at in the next result.

Sub Test_GetTopFive()
    GetTopFive Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
End Sub

Sub GetTopFive(r As Range)
    Dim v, t, m, i As Long, j As Long, rw As Long
    
    t = Application.WorksheetFunction.Aggregate(14, 6, r.Columns(2), 5)
    m = t - 1
    v = r
    For i = 1 To 5
        For j = 1 To UBound(v, 1)
            If Not IsError(v(j, 2)) Then
                If v(j, 2) >= t Then
                    If v(j, 2) > m Then
                        m = v(j, 2)
                        rw = j
                    End If
                End If
            End If
        Next j
        If rw > 0 Then
            Debug.Print v(rw, 1), v(rw, 2)
            v(rw, 2) = 0
            m = t - 1
            rw = 0
        End If
    Next i
End Sub
Simon
  • 1,384
  • 2
  • 10
  • 19
1

I don't understand why you are using VBA for that: in order to get the five larges values (e.g. from range A2:A10), I just type those five formulas (e.g. in range "C1:C5"):

=LARGE(A$2:A$10,1) 'in cell C1, there you get the largest value.
=LARGE(A$2:A$10,2) 'in cell C2, there you get the second largest value.
=LARGE(A$2:A$10,3) 'in cell C3, there you get the third  largest value.
=LARGE(A$2:A$10,4) 'in cell C4, there you get the fourth largest value.
=LARGE(A$2:A$10,5) 'in cell C5, there you get the fifth  largest value.
Dominique
  • 16,450
  • 15
  • 56
  • 112
  • Thanks a lot. I would like to return the names and the marks in the immediate window, not just get the highest values. – YasserKhalil Aug 19 '21 at 06:18
  • 1
    You can use a `Vlookup()` for getting the corresponding names (I imagine they are in another column on the same row). – Dominique Aug 19 '21 at 06:30
  • Yes, that's right but there's a problem when the highest marks are similar at some point. Imagine there are two of the names that have the same mark 95. In that case, the return result will not be correct. – YasserKhalil Aug 19 '21 at 07:05
  • 1
    @YasserKhalil then you did not check out the answer I gave you - my solution deals with duplicates… – Solar Mike Aug 19 '21 at 07:32
1

VBA Top Values

Some Issues

  • In this case, the WorksheetFunction.Aggregate function will raise an error e.g. if there are less than 5 numeric values. What to do in such a case?
  • How to resolve the ties? Pick the first appearing in the range?
  • Application.Max will return an error if there are error values.
  • Application.Max will not consider blanks as zeros.
  • Application.Match will return an error if there was no match.
  • What if there are negative numbers (ridiculous in this case)?
Option Explicit

Sub Test_DebugPrintTop()
    Dim rg As Range: Set rg = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row)
    DebugPrintTop rg, 5, False
End Sub

Sub DebugPrintTop( _
        ByVal rg As Range, _
        ByVal TopCount As Long, _
        Optional ByVal IncludeBlanks As Boolean = False)
    
    If rg Is Nothing Then
        Debug.Print "No range."
        Exit Sub
    End If
    
    If TopCount < 1 Then
        Debug.Print "'TopCount' has to be a positive integer."
        Exit Sub
    End If
    
    Dim sData As Variant: sData = rg.Resize(, 2).Value ' only 2 columns
    Dim sData2 As Variant: sData2 = rg.Columns(2).Value ' 2nd column
    Dim srCount As Long: srCount = UBound(sData, 1)
    
    Dim r As Long
    Dim srValue As Variant: srValue = Application.Max(sData2)
    If IsError(srValue) Then
        For r = 1 To srCount
            ' Check for error values and replace them with 'Empty' values.
            If IsError(sData2(r, 1)) Then
                sData(r, 2) = Empty
                sData2(r, 1) = Empty
            End If
        Next r
    End If
    
    If IncludeBlanks Then
        For r = 1 To srCount
            ' Check for blanks and replace them with zeros.
            If Len(sData2(r, 1)) = 0 Then
                sData(r, 2) = 0
                sData2(r, 1) = 0
            End If
        Next r
    End If
    
    Dim srIndexes() As Long
    Dim srIndex As Variant
    Dim drCount As Long
    For r = 1 To TopCount
        srValue = Application.Max(sData2)
        srIndex = Application.Match(srValue, sData2, 0)
        If IsNumeric(srIndex) Then
            drCount = drCount + 1
            ReDim Preserve srIndexes(1 To drCount)
            srIndexes(drCount) = srIndex
            sData2(srIndex, 1) = Empty ' not 0
        Else
            Exit For
        End If
    Next r
    
    If drCount = 0 Then
        Debug.Print "No numbers."
        Exit Sub
    End If
    
    For r = 1 To drCount
        Debug.Print sData(srIndexes(r), 1), sData(srIndexes(r), 2)
    Next r
    
    ' An idea to make e.g. the 'GetTop' function from it.
'    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 2)
'    For r = 1 To drCount
'        dData(r, 1) = sData(srIndexes(r), 1)
'        dData(r, 2) = sData(srIndexes(r), 2)
'    Next r
'    GetTop = dData
    
End Sub
VBasic2008
  • 44,888
  • 5
  • 17
  • 28