成绩统计的求和与排名

wqy629

求大神帮我用代码算一下成绩。
    1.将“使用说明”表中的课程名称C3-G3,自动填充到“一年级”表中的F2-J2。当“使用说明”表中的课程顺序变动时，它也可以一键更新。
    2.在“一年级”表中可以算出总分、班级排名以及年级排名。排名时要可以并列，比如1班的张三1和2班的李四1都是413分，并列年级第1名。班级排名也是可以并列。
    只要达到以上两个要求即可。期末统分在即，坐等大社出现。

wqy629

还有一点，将“一年级”表中E列中的班级不重复地填充到‘使用说明’表的B4－B13中。这点做不到也无所谓。请大神帮我注明一下代码的意思。

魂断蓝桥

Option Explicit

Sub pm()
Dim arr, d, i, brr(1 To 9999, 1 To 2), j, zf
Sheet1.[c2:g2].Copy
Range("F2").PasteSpecial Paste:=xlPasteValues
[k3:k9999] = ""
arr = [a1].CurrentRegion
For i = 3 To UBound(arr)
    For j = 6 To 10
        zf = zf + arr(i, j)
    Next
        Cells(i, "k") = zf
        zf = 0
Next
j = i - 1
Set arr = Range("k3:k" & j)
Set d = CreateObject("scripting.dictionary")
For i = 3 To j
    If Not d.exists(Cells(i, "e").Value) Then
        Set d(Cells(i, "e").Value) = Cells(i, "k")
    Else
        Set d(Cells(i, "e").Value) = Union(d(Cells(i, "e").Value), Cells(i, "k"))
    End If
Next
For i = 3 To j
    brr(i - 2, 2) = Application.Rank(Cells(i, "k"), arr)
    brr(i - 2, 1) = Application.Rank(Cells(i, "k"), d(Cells(i, "e").Value))
Next
[l3].Resize(i - 2, 2) = brr
Set d = Nothing
End Sub

一把小刀闯天下

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

wqy629

魂断蓝桥 发表于 2019-1-18 12:48
Option Explicit

Sub pm()

谢谢了，可以用。能再帮我完善一下吗？就是从各年级工作表的不同班级也填充到“使用说明”去，这样就非常完美了。谢谢

魂断蓝桥

wqy629 发表于 2019-1-18 14:38
谢谢了，可以用。能再帮我完善一下吗？就是从各年级工作表的不同班级也填充到“使用说明”去，这样就非常 ...

没看懂，能再举例说明一下吗

wqy629

魂断蓝桥 发表于 2019-1-18 15:04
没看懂，能再举例说明一下吗

就是有“一年级”E列不同班级填充到“使用说明”B4－B13(不到10个班的就保留空白)；“二年级”E列填充到“使用说明”的B17－B26，以此类推……  麻烦你了大神。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   For Each ws In Worksheets
   
8.     If ws.Name Like "*年级" Then
   
9.       With ws
   
10.         r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
11.         arr = .Range("e3:e" & r)
    
12.         For i = 1 To UBound(arr)
    
13.           nj = Left(arr(i, 1), 1)
    
14.           bj = Mid(arr(i, 1), 2)
    
15.           If Not d.exists(nj) Then
    
16.             m = 1
    
17.             ReDim brr(1 To m)
    
18.           Else
    
19.             brr = d(nj)
    
20.             m = UBound(brr) + 1
    
21.             ReDim Preserve brr(1 To m)
    
22.           End If
    
23.           brr(m) = bj
    
24.           d(nj) = brr
    
25.         Next
    
26.       End With
    
27.     End If
    
28.   Next
    
29.   With Worksheets("使用说明")
    
30.     For Each aa In d.keys
    
31.       brr = d(aa)
    
32.       m = InStr("一二三四五六七八九", aa) * 13 - 9
    
33.       .Cells(m, 2).Resize(10, 1).ClearContents
    
34.       .Cells(m, 2).Resize(UBound(brr), 1) = Application.Transpose(brr)
    
35.     Next
    
36.   End With
    
37. End Sub
    

复制代码

chxw68

系统出错，附件传不上来。