获得成绩最高的前五名学生

Question

我已经搜索并发现了一个代码，该代码提取了得分最高的前五个名称。代码没问题，我可以得到名字和标记

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

但是直接窗口中的结果没有排序。我需要先得到最高分的名字。

Answer 1

试试下面的代码。棘手的部分是你不能对数组进行排序，所以我让它循环你想要的结果的数量，然后对每个结果循环遍历数组，找到最大值。一旦找到，它打印它，然后将它的值设置为0，以便在下一个结果中删除它。

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

Answer 2

我不明白你为什么要使用VBA:为了获得五个大值(例如从范围A2:A10)，我只是键入这五个公式(例如在范围"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.

Answer 3

VBA Top Values

若干问题

在<<ul>

strong>这在这种情况下，WorksheetFunction.Aggregate函数将引发错误，例如，如果小于5个数值。在这种情况下该怎么办?

如何解决关系?选择第一个出现在范围内的?

Application.Max将返回

Application.Max将不考虑空白为零。

Application.Match将返回

如果有负数(在这种情况下很荒谬)怎么办?

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