'自己修改
Option Explicit
Sub test()
Dim arr, i, j, k, kk, n
arr = [a1].CurrentRegion.Offset(1)
ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)
Call dsort(arr, 1, UBound(arr, 1) - 1, 6, False) '降序
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 6) <> arr(j + 1, 6) Then
If j > i Then Call dsort(arr, i, j, 4, False) '降序
n = 1
For k = 1 To UBound(arr, 2): brr(i, k) = arr(i, k): Next
brr(i, k) = n
For k = i + 1 To j
If arr(k, 4) <> arr(k - 1, 4) Then n = n + 1 '可能有并列名次
For kk = 1 To UBound(arr, 2): brr(k, kk) = arr(k, kk): Next
brr(k, kk) = n
Next
i = j: Exit For
End If
Next j, i
' Call dsort(brr, 1, UBound(brr, 1) - 1, 1, true)'Sort for Row ID
[h2].Resize(UBound(brr, 1) - 1, UBound(brr, 2)) = brr
End Sub
Function dsort(arr, first, last, key, order)
Dim i, j, k, t
For i = first To last - 1
For j = i + 1 To last
If arr(i, key) < arr(j, key) Xor order Then
For k = 1 To UBound(arr, 2)
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
End Function |