高考成绩上线VBA解决（感谢褚老师和小刀老师）

vvw123

用公式处理，慢，工作表大，请大侠用VBA指点指点。
根据分数线填充对应等级，
例如理科生：总分620，那么上线就是“前X名”，该生语文100，那么语文的上线就是“重点”，

一把小刀闯天下

条件不够，理科班级排是指仅在理科班还是在所有班级里级排，看了一下这问题非常繁琐，，，

vvw123

一把小刀闯天下 发表于 2018-12-1 16:11
条件不够，理科班级排是指仅在理科班还是在所有班级里级排，看了一下这问题非常繁琐，，，

感谢帮助，级排是指理科类班级排名。因为文理分科，相同科目的语文，英语，数学三科试卷都不同，都分文理了。文科类还考政治，历史，地理。理科类考物理化学生物。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("设置")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:g" & r)
   
9.     vs = [{"专科","本科","重点","前X名","第一名"}]
   
10.   End With
    
11.   For i = 2 To UBound(arr)
    
12.     If Not d.exists(arr(i, 1)) Then
    
13.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
14.     End If
    
15.     Select Case arr(i, 2)
    
16.       Case "物理", "政治"
    
17.         km = "物政"
    
18.       Case "化学", "历史"
    
19.         km = "化历"
    
20.       Case "生物", "地理"
    
21.         km = "生地"
    
22.       Case "理数", "文数"
    
23.         km = "数学"
    
24.       Case "理综", "文综"
    
25.         km = "综合"
    
26.       Case Else
    
27.         km = arr(i, 2)
    
28.     End Select
    
29.     d(arr(i, 1))(km) = Array(arr(i, 7), arr(i, 6), arr(i, 5), arr(i, 4), arr(i, 3))
    
30.   Next
    
31.   With Worksheets("成绩表")
    
32.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
33.     .Range("o4:ag" & r).ClearContents
    
34.     arr = .Range("a2:ag" & r)
    
35.     For i = 3 To UBound(arr)
    
36.       If d.exists(arr(i, 3)) Then
    
37.         For j = 7 To 13
    
38.           If d(arr(i, 3)).exists(arr(1, j)) Then
    
39.             brr = d(arr(i, 3))(arr(1, j))
    
40.             n = Application.Match(arr(i, j), brr)
    
41.             If Not IsError(n) Then
    
42.               arr(i, j * 2 + 7) = vs(n)
    
43.             End If
    
44.           End If
    
45.         Next
    
46.       End If
    
47.     Next
    
48.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
49.   End With
    
50. End Sub
    

复制代码

chxw68

只写了上线代码，不知道结果正确与否，级排没看懂意思。

vvw123

chxw68 发表于 2018-12-1 17:06
只写了上线代码，不知道结果正确与否，级排没看懂意思。

谢谢褚老师，今天小红花只有一分，明天再送上。

chxw68

vvw123 发表于 2018-12-1 17:09
谢谢褚老师，今天小红花只有一分，明天再送上。

你详细说明一下级排是怎么排的？

一把小刀闯天下

vvw123 发表于 2018-12-1 16:17
感谢帮助，级排是指理科类班级排名。因为文理分科，相同科目的语文，英语，数学三科试卷都不同，都分文理 ...

'褚老师写了上线代码，我正好写了个排名，上线看上去晕，那就不写了，，，

'自己测试一下
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

vvw123

一把小刀闯天下 发表于 2018-12-1 17:22
'褚老师写了上线代码，我正好写了个排名，上线看上去晕，那就不写了，，，

'自己测试一下

谢谢老师，今天小红花送完了，明天再送。

vvw123

chxw68 发表于 2018-12-1 17:22
你详细说明一下级排是怎么排的？

谢谢褚老师，是这样排的：所有同类的排名，例如：所有理科的作为一类来排名，
公式是这样的：

1. =SUM(($C$4:$C$999=$C4)*(N$4:N$999<>"")*(N$4:N$999>N4))+1

复制代码

三键组合