查找范围内的最高值和后续值

Question

我有下面的代码，它应该在一个范围内找到第一个、第二个、第三个和第四个最高值。

它目前非常基础，我让它在 MsgBox 中提供值，这样我就可以确认它是否正常工作。

但是，它只能找到最高值和第二高值。第三个和第四个值返回为 0。我错过了什么？

Sub Macro1()

Dim rng As Range, cell As Range
Dim firstVal As Double, secondVal As Double, thirdVal As Double, fourthVal As Double

Set rng = [C4:C16]

For Each cell In rng
    If cell.Value > firstVal Then firstVal = cell.Value
    If cell.Value > secondVal And cell.Value < firstVal Then secondVal = 
    cell.Value
    If cell.Value > thirdVal And cell.Value < secondVal Then thirdVal = 
    cell.Value
    If cell.Value > fourthVal And cell.Value < thirdVal Then fourthVal = 
    cell.Value
Next cell

MsgBox "First Highest Value is " & firstVal
MsgBox "Second Highest Value is " & secondVal
MsgBox "Third Highest Value is " & thirdVal
MsgBox "Fourth Highest Value is " & fourthVal

End Sub

Answer 1

使用Application.WorksheetFunction.Large():

Sub Macro1()

Dim rng As Range, cell As Range
Dim firstVal As Double, secondVal As Double, thirdVal As Double, fourthVal As Double

Set rng = [C4:C16]


firstVal = Application.WorksheetFunction.Large(rng,1)
secondVal = Application.WorksheetFunction.Large(rng,2)        
thirdVal = Application.WorksheetFunction.Large(rng,3)
fourthVal = Application.WorksheetFunction.Large(rng,4)

MsgBox "First Highest Value is " & firstVal
MsgBox "Second Highest Value is " & secondVal
MsgBox "Third Highest Value is " & thirdVal
MsgBox "Fourth Highest Value is " & fourthVal

End Sub

Answer 2

你有上面Scott Craner建议的更好的方法。但是，为了回答您的问题，您只返回了有限数量的值，因为您正在覆盖这些值，而没有将原始值转移到较低的等级。

Dim myVALs As Variant
myVALs = Array(0, 0, 0, 0, 0)

For Each cell In rng
    Select Case True
        Case cell.Value2 > myVALs(0)
            myVALs(4) = myVALs(3)
            myVALs(3) = myVALs(2)
            myVALs(2) = myVALs(1)
            myVALs(1) = myVALs(0)
            myVALs(0) = cell.Value2
        Case cell.Value2 > myVALs(1)
            myVALs(4) = myVALs(3)
            myVALs(3) = myVALs(2)
            myVALs(2) = myVALs(1)
            myVALs(1) = cell.Value2
        Case cell.Value2 > myVALs(2)
            myVALs(4) = myVALs(3)
            myVALs(3) = myVALs(2)
            myVALs(2) = cell.Value2
        Case cell.Value2 > myVALs(3)
            myVALs(4) = myVALs(3)
            myVALs(3) = cell.Value2
        Case cell.Value2 > myVALs(4)
            myVALs(4) = cell.Value2
        Case Else
            'do nothing
    End Select
Next cell

Debug.Print "first: " & myVALs(0)
Debug.Print "second: " & myVALs(1)
Debug.Print "third: " & myVALs(2)
Debug.Print "fourth: " & myVALs(3)
Debug.Print "fifth: " & myVALs(4)

Answer 3

Excel wroksheetfuntion 将是一个更好的选择，因为 task.This 将允许用户 select 范围，并将它们发布在任何具有无效数据的范围内。可以为 Top4 值声明另一种 Double 数据类型，也可以更新相同的 msgbox。这将避免宏中出现任何类型的错误。

Sub top_three()

Dim Area As Range
Dim Tone As Double, Ttwo As Double, Tthree As Double

On Error GoTo Skip

Set Area = Excel.Application.InputBox("Select the Range", "Data Visulaization", 
Type:=8)

If Excel.Application.WorksheetFunction.Count(Area) >= 3 Then

Tone = Excel.WorksheetFunction.Large(Area, 1)
Ttwo = Excel.WorksheetFunction.Large(Area, 2)
Tthree = Excel.WorksheetFunction.Large(Area, 3)

VBA.Interaction.MsgBox "Top 1: " & Tone & VBA.Constants.vbNewLine & _
"Top 2: " & Ttwo & VBA.Constants.vbNewLine & "Top 3:" & Tthree, Title:= _
"Top 3 values"

Else

VBA.Interaction.MsgBox "No Enough Data type to perform the task", vbInformation

End If

Skip:

End Sub

查找范围内的最高值和后续值

Finding highest and subsequent values in a range

excel

vba

worksheet-function