求助：按条件生成排名

pencilwhs

按条件生成排名

蓝桥玄霜

排名的例子：

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, p
  arr = [a1].CurrentRegion.Offset(1).Resize(, 28).Value
  For i = 1 To UBound(arr, 1) - 1
    arr(i, 28) = -i
  Next
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 25)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 25) <> arr(i + 1, 25) Then
      For j = 4 To 22 Step 2
        Call qsort(arr, p + 1, i, 1, UBound(arr, 2), j)
        Call rank(arr, p + 1, i, j, j + 1, True)
      Next
      p = i
    End If
  Next
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 28)
  [a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) \ 2, key)
  While i <= j
    While arr(i, key) > x: i = i + 1: Wend
    While x > arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

Function rank(arr, first, last, key, col, order As Boolean)
  Dim i As Long, j As Long, m As Long
  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
    If arr(i, key) = arr(i - 1, key) Then
      arr(i, col) = arr(i - 1, col)
    Else
      arr(i, col) = m
    End If
  Next
End Function

pencilwhs

一把小刀闯天下 发表于 2021-3-8 15:58
Option Explicit

Sub test()

非常感谢！我运行了一下，好像不对，我要实现的目标是：先按考试名称，再按选科类别。而你写的只是按照选科类别排名。麻烦您有空时帮我修改一下，我没有学过VBA，平时只是用函数操作，但是数据多的时候函数运行很忙很卡。万分感激！

pencilwhs

蓝桥玄霜 发表于 2021-3-8 13:34
排名的例子：

非常感谢！不过我没有学过VBA，所以不懂得怎么把你发个例子修改。

pencilwhs

pencilwhs 发表于 2021-3-8 19:45
非常感谢！我运行了一下，好像不对，我要实现的目标是：先按考试名称，再按选科类别。而你写的只是按照选 ...

能把代码放到excel再发给我吗？谢谢！

一把小刀闯天下

pencilwhs 发表于 2021-3-8 19:45
非常感谢！我运行了一下，好像不对，我要实现的目标是：先按考试名称，再按选科类别。而你写的只是按照选 ...

'你这变成了一个文字题，加了个条件自己再试一下，另外无分数作清空处理了

'优先级：考试名称->选科1->各科分数降序美式排名，如果是中式改成false就可以了，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, p
  arr = [a1].CurrentRegion.Offset(1).Resize(, 28).Value
  For i = 1 To UBound(arr, 1) - 1
    arr(i, 28) = -i
  Next
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call qsort(arr, p + 1, i, 1, UBound(arr, 2), 25)
      For j = p + 1 To i
        If arr(j, 25) <> arr(j + 1, 25) Or j = i Then
          For k = 4 To 22 Step 2
            Call qsort(arr, p + 1, j, 1, UBound(arr, 2), k)
            Call rank(arr, p + 1, j, k, k + 1, True)
            For kk = p + 1 To j
              If Len(arr(kk, k)) = 0 Then arr(kk, k + 1) = vbNullString
            Next
          Next
          p = j
        End If
      Next
      p = i
    End If
  Next
  Call qsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 28)
  [a2].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x, t
  i = first: j = last: x = arr((first + last) \ 2, key)
  While i <= j
    While arr(i, key) > x: i = i + 1: Wend
    While x > arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

Function rank(arr, first, last, key, col, order As Boolean)
  Dim i As Long, j As Long, m As Long
  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
    If arr(i, key) = arr(i - 1, key) Then
      arr(i, col) = arr(i - 1, col)
    Else
      arr(i, col) = m
    End If
  Next
End Function

一把小刀闯天下

'上传代码不审核我都会去买张彩票的

'有图才有真相，没事自己先抄写一下吧


-------------

pencilwhs

一把小刀闯天下 发表于 2021-3-8 20:27
'你这变成了一个文字题，加了个条件自己再试一下，另外无分数作清空处理了

'优先级：考试名称->选科1- ...

搞定了，完美，真的太感谢你了！