[已解决]成绩统计排名

dyzx

请高手出马帮忙设计，能够自动统计总分、班排名和级排名，但在随意增减科目成绩后，又能自动统计出总分、班排名和级排名，又要同时写入表头（总分、班排名、级排名），多谢各位高手指教。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-7-1 21:55

1. Sub tj()
   
2.     arr = [a1].CurrentRegion
   
3.     r = UBound(arr)
   
4.     c = UBound(arr, 2)
   
5.     ReDim brr(3 To UBound(arr), 1 To 3)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Dim NjRng As Range       '年级区域
   
8.    
   
9.     qs = 3           '起始
   
10.     For i = 3 To r
    
11.         For j = 4 To c
    
12.             brr(i, 1) = brr(i, 1) + arr(i, j)
    
13.         Next
    
14.         If (i > 3 And arr(i, 1) <> arr(i - 1, 1)) Or i = r Then
    
15.             js = IIf(i = r, r, i - 1)       '结束
    
16.             d(arr(i - 1, 1)) = qs & "," & js
    
17.             qs = i       '下一起始
    
18.         End If
    
19.     Next
    
20.     Cells(2, c + 1) = "总分": Cells(2, c + 2) = "班排名": Cells(2, c + 3) = "级排名"
    
21.     Cells(3, c + 1).Resize(i - 3) = brr
    
22.     Set NjRng = Range(Cells(3, c + 1), Cells(r, c + 1))
    
23.     For i = 3 To r
    
24.         qs = Split(d(arr(i, 1)), ",")(0)
    
25.         js = Split(d(arr(i, 1)), ",")(1)
    
26.         brr(i, 2) = Application.WorksheetFunction.Rank(brr(i, 1), Range(Cells(qs, c + 1), Cells(js, c + 1)))
    
27.         brr(i, 3) = Application.WorksheetFunction.Rank(brr(i, 1), NjRng)
    
28.     Next
    
29.     Cells(3, c + 1).Resize(i - 3, 3) = brr
    
30. End Sub
    

复制代码

跳转到最佳答案楼层

today0427

模拟个结果看看

grf1973

1. Sub tj()
   
2.     arr = [a1].CurrentRegion
   
3.     r = UBound(arr)
   
4.     c = UBound(arr, 2)
   
5.     ReDim brr(3 To UBound(arr), 1 To 3)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Dim NjRng As Range       '年级区域
   
8.    
   
9.     qs = 3           '起始
   
10.     For i = 3 To r
    
11.         For j = 4 To c
    
12.             brr(i, 1) = brr(i, 1) + arr(i, j)
    
13.         Next
    
14.         If (i > 3 And arr(i, 1) <> arr(i - 1, 1)) Or i = r Then
    
15.             js = IIf(i = r, r, i - 1)       '结束
    
16.             d(arr(i - 1, 1)) = qs & "," & js
    
17.             qs = i       '下一起始
    
18.         End If
    
19.     Next
    
20.     Cells(2, c + 1) = "总分": Cells(2, c + 2) = "班排名": Cells(2, c + 3) = "级排名"
    
21.     Cells(3, c + 1).Resize(i - 3) = brr
    
22.     Set NjRng = Range(Cells(3, c + 1), Cells(r, c + 1))
    
23.     For i = 3 To r
    
24.         qs = Split(d(arr(i, 1)), ",")(0)
    
25.         js = Split(d(arr(i, 1)), ",")(1)
    
26.         brr(i, 2) = Application.WorksheetFunction.Rank(brr(i, 1), Range(Cells(qs, c + 1), Cells(js, c + 1)))
    
27.         brr(i, 3) = Application.WorksheetFunction.Rank(brr(i, 1), NjRng)
    
28.     Next
    
29.     Cells(3, c + 1).Resize(i - 3, 3) = brr
    
30. End Sub
    

复制代码

dyzx

grf1973 发表于 2016-7-1 21:55

grf1973老师：就是这个效果，多谢。