Excel VBA 需要背代码吗-EXCEL VBA轻松处理超难排名问题

我们大家可能经常用EXCEL来制作排名表吧，用rank函数还是比较简单的。

但是如果你看下面的情况，会显示相当麻烦

摘自：办公小助手（头条号）

数据源：

要求：依据F列的成绩，分别进行全市，全省，全国排名！

那我们该如何解决呢？

建个宏，代码如下：

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列为小类均可使用。

朋友们，怎么样简单吧，感觉复制代码，去试试看噻。