Sub 排名()
Dim r&, i&
Dim arr
tt = Timer
Dim d1 As Object, d2 As Object, d3 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("g4:i" & r).ClearContents
arr = .Range("a4:i" & r)
For i = 1 To UBound(arr)
If Len(arr(i, 6)) <> 0 Then
d1(arr(i, 6)) = d1(arr(i, 6)) + 1
If Not d2.exists(arr(i, 5)) Then
Set d2(arr(i, 5)) = CreateObject("scripting.dictionary")
End If
d2(arr(i, 5))(arr(i, 6)) = d2(arr(i, 5))(arr(i, 6)) + 1
If Not d3.exists(arr(i, 5)) Then
Set d3(arr(i, 5)) = CreateObject("scripting.dictionary")
End If
If Not d3(arr(i, 5)).exists(arr(i, 4)) Then
Set d3(arr(i, 5))(arr(i, 4)) = CreateObject("scripting.dictionary")
End If
d3(arr(i, 5))(arr(i, 4))(arr(i, 6)) = d3(arr(i, 5))(arr(i, 4))(arr(i, 6)) + 1
End If
Next
KK = d1.keys
nn = 1
For k = 0 To UBound(KK)
mm = Application.Large(KK, k + 1)
ss = d1(mm)
d1(mm) = nn
nn = nn + ss
Next
For Each aa In d2.keys
KK = d2(aa).keys
nn = 1
For k = 0 To UBound(KK)
mm = Application.Large(KK, k + 1)
ss = d2(aa)(mm)
d2(aa)(mm) = nn
nn = nn + ss
Next
Next
For Each aa In d3.keys
For Each bb In d3(aa).keys
KK = d3(aa)(bb).keys
nn = 1
For k = 0 To UBound(KK)
mm = Application.Large(KK, k + 1)
ss = d3(aa)(bb)(mm)
d3(aa)(bb)(mm) = nn
nn = nn + ss
Next
Next
Next
For i = 1 To UBound(arr)
If Len(arr(i, 6)) <> 0 Then
arr(i, 9) = d1(arr(i, 6))
arr(i, 8) = d2(arr(i, 5))(arr(i, 6))
arr(i, 7) = d3(arr(i, 5))(arr(i, 4))(arr(i, 6))
End If
Next
.Range("a4").Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub
这里要说下，本工作表表名要是Sheet1，如果不是，你可以要让第七排的代码“With Worksheets("Sheet1")”修改为自己的表名；还有要保证成绩在F这一栏哦。该代码适用范围比较广，比如也可用于班级年级排名等，只要保证E列为大类，F列为小类均可使用。
