本帖最后由 一把小刀闯天下 于 2018-12-1 17:24 编辑
'褚老师写了上线代码,我正好写了个排名,上线看上去晕,那就不写了,,,
'自己测试一下
Option Explicit
Sub test()
Dim arr, i, j, k, temp, pos, a, b
With Sheets("成绩表")
arr = .Range("c4:ah" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
End With
temp = arr
For i = 1 To UBound(arr, 1) - 1: arr(i, 32) = i: Next
pos = Array(12, 13, 5, 18, 6, 20, 7, 22, 8, 24, 9, 26, 10, 28, 11, 30) '级排
Call msort(arr, temp, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1, False) '类别降序
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 1) <> arr(j + 1, 1) Then
For k = 0 To UBound(pos) Step 2
Call msort(arr, temp, i, j, 1, UBound(arr, 2), pos(k), False) '同类别年级指定科目降序
Call rank(arr, i, j, pos(k), pos(k + 1)) '指定科目排名
Next
Call msort(arr, temp, i, j, 1, UBound(arr, 2), 3, True) '同类别按班级升序
For a = i To j
For b = a To j
If arr(b, 1) <> arr(b + 1, 1) Or arr(b, 3) <> arr(b + 1, 3) Then
Call msort(arr, temp, a, b, 1, UBound(arr, 2), 12, False) '同类别班级总分降序
Call rank(arr, a, b, 12, 14) '总分班排
a = b: Exit For
End If
Next b, a
i = j: Exit For
End If
Next j, i
Call msort(arr, temp, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 32, True) '恢复
Sheets("成绩表").[c4].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
End Sub
Function rank(arr, first, last, key, col)
Dim i, j, m
m = 1: arr(first, col) = 1
For i = first + 1 To last
m = m + 1
arr(i, col) = IIf(arr(i, key) = arr(i - 1, key), arr(i - 1, col), m)
Next
End Function
Function msort(arr, temp, first, last, left, right, key, order)
Dim i As Long, j As Long, k As Long, kk As Long, mid As Long
If first <> last Then
mid = Int((first + last) / 2)
msort arr, temp, first, mid, left, right, key, order
msort arr, temp, mid + 1, last, left, right, key, order
i = first: j = mid + 1: k = first
While i <= mid And j <= last
If arr(i, key) > arr(j, key) Xor order Then
For kk = left To right: temp(k, kk) = arr(i, kk): Next
k = k + 1: i = i + 1
Else
For kk = left To right: temp(k, kk) = arr(j, kk): Next
k = k + 1: j = j + 1
End If
Wend
While i <= mid
For kk = left To right: temp(k, kk) = arr(i, kk): Next
k = k + 1: i = i + 1
Wend
While j <= last
For kk = left To right: temp(k, kk) = arr(j, kk): Next
k = k + 1: j = j + 1
Wend
For i = first To last
For j = left To right
arr(i, j) = temp(i, j)
Next j, i
End If
End Function
|