本帖最后由 一把小刀闯天下 于 2019-1-18 13:42 编辑
Option Explicit
Sub test()
Dim arr, i, j, sum, title
arr = Sheets("一年级").[a2].CurrentRegion.Offset(1).Resize(, 15)
For i = 1 To UBound(arr, 1) - 1
arr(i, 15) = i: sum = 0
For j = 6 To 10: sum = sum + arr(i, j): Next
arr(i, j) = sum
Next
Call dsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 11, False)
Call rank(arr, 1, UBound(arr, 1) - 1, 11, 13, True)
Call dsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 5, True)
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 5) <> arr(j + 1, 5) Then
Call dsort(arr, i, j, 1, UBound(arr, 2), 11, False)
Call rank(arr, i, j, 11, 12, True)
i = j: Exit For
End If
Next j, i
Call dsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 15, True)
title = Sheets("使用说明").[c2:g2]
With Sheets("一年级").[a3]
.Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
.Offset(-1, 5).Resize(, UBound(title, 2)) = title
End With
End Sub
Function dsort(arr, first, last, left, right, 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 = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
End Function
Function rank(arr, first, last, key, col, order)
Dim i, j, m
m = 1: arr(first, col) = 1
For i = first + 1 To last
If order Then
m = m + 1
Else
If arr(i, key) <> arr(i - 1, key) Then m = m + 1
End If
arr(i, col) = IIf(arr(i, key) = arr(i - 1, key), arr(i - 1, col), m)
Next
End Function
|