VBA应用(中国式排名和西式排名)

VBA应用-实现中西式排名一、效果图
二、主要实现
'Option Explicit
Sub paiming1() '中国式分组排名
Dim D1, D2, arr, arr1, i, T
arr = [a2:e33]
Set D1 = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr, 1)
D1(arr(i, 1)) = "" '取得分组名称
Next
T = D1.keys
Set D2 = CreateObject("scripting.dictionary")
'存入分数
For P = 0 To D1.Count - 1
For i = 1 To UBound(arr, 1)
If arr(i, 1) = T(P) Then D2(arr(i, 4)) = 0
Next
For i = 1 To D2.Count
D2(rge(D2.keys, i)) = T(P) & "－" & i
Next
For i = 2 To UBound(arr, 1) + 1
If Cells(i, 1) = T(P) Then Cells(i, 5) = D2(Cells(i, 4).Value)
Next
Next P
End Sub
Sub 中西式排名() '
Dim D1, D2, arr, arr1, i, T
[E2:F40].ClearContents '清除原有数据
arr = [a2:e33]
Set D1 = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr, 1)
D1(arr(i, 1)) = "" '取得分组名称
Next
T = D1.keys
'－－－
For i = 0 To UBound(T) '循环分组
ReDim arr1(1 To 34, 1 To 5)
For j = 1 To UBound(arr, 1)
If arr(j, 1) = T(i) Then
P = P + 1
arr1(P, 1) = arr(j, 1): arr1(P, 2) = arr(j, 2): arr1(P, 3) = arr(j, 3): arr1(P, 4) = arr(j, 4)
End If
Next j
'降序
For h = 1 To UBound(arr1, 1) - 1
For h1 = h + 1 To UBound(arr1, 1)
If arr1(h, 4) < arr1(h1, 4) Then
temp1 = arr1(h1, 1): temp2 = arr1(h1, 2): temp3 = arr1(h1, 3): temp4 = arr1(h1, 4)
arr1(h1, 1) = arr1(h, 1): arr1(h1, 2) = arr1(h, 2): arr1(h1, 3) = arr1(h, 3): arr1(h1, 4) = arr1(h, 4)
arr1(h, 1) = temp1: arr1(h, 2) = temp2: arr1(h, 3) = temp3: arr1(h, 4) = temp4
End If
Next h1
Next h
' 西式排名
arr1(1, 5) = T(i) & "-" & 1
For h = 2 To UBound(arr1, 1)
If arr1(h, 4) = "" Then Exit For
If arr1(h, 4) <> arr1(h - 1, 4) Then arr1(h, 5) = T(i) & "-" & h Else arr1(h, 5) = T(i) & "-" & Split(arr1(h - 1, 5), "-")(1)
Next h
For a = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For a1 = 1 To UBound(arr1, 1)
If Cells(a, 1) = T(i) And Cells(a, 4) = arr1(a1, 4) Then Cells(a, 6) = arr1(a1, 5)
Next a1
Next a
''
' 中式
arr1(1, 5) = T(i) & "-" & 1
For h = 2 To UBound(arr1, 1)
If arr1(h, 4) = "" Then Exit For
If arr1(h, 4) < arr1(h - 1, 4) Then arr1(h, 5) = T(i) & "-" & Split(arr1(h - 1, 5), "-")(1) + 1 Else arr1(h, 5) = T(i) & "-" & Split(arr1(h - 1, 5), "-")(1)
Next h
For a = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For a1 = 1 To UBound(arr1, 1)
If Cells(a, 1) = T(i) And Cells(a, 4) = arr1(a1, 4) Then Cells(a, 5) = arr1(a1, 5)
Next a1
Next a
WaitaLong '等待
Next i
End Sub
Public Sub WaitaLong()
Dim t1
t1 = Timer
Do Until Timer > t1 + 4
DoEvents
Loop
Debug.Print t1, Timer
End Sub。