[已解决]用宏给学生排名。。。。

幻Θ影

想用宏给学生排名。。。。详见附件。。。求各位帮帮忙忙谢谢。。
用宏排名.rar (2.73 KB, 下载次数: 13)

2015-3-23 16:08 上传

点击文件名下载附件


注；最后一名如果有并列，要一起列出来…………也就是有并列时不只15人。

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-24 21:45

………………

跳转到最佳答案楼层

幻Θ影

高手在哪里？？？

幻Θ影

求高手啊…………

幻Θ影

高手都下班了？？？？

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&, k%, j%, kk%, l%, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 20000, 1 To 7)
   
5. [a3:g65536] = ""
   
6. For k = 1 To 2
   
7.     bj = Sheets(k).Name: s = 0
   
8.     arr = Sheets(k).Range("a2").CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         If Not d.exists(arr(i, 5)) Then
    
11.             d(arr(i, 5)) = i
    
12.         Else
    
13.             d(arr(i, 5)) = d(arr(i, 5)) & "," & i
    
14.         End If
    
15.     Next
    
16.     For j = 1 To [i1]
    
17.        n = Application.Large(d.keys, j)
    
18.        x = Split(d(n), ",")
    
19.        For kk = 0 To UBound(x)
    
20.             s = s + 1
    
21.             brr(s, 1) = bj
    
22.             For l = 1 To UBound(arr, 2)
    
23.                 brr(s, l + 1) = arr(x(kk), l)
    
24.             Next
    
25.        Next
    
26.     Next
    
27.     s2 = Range("a65536").End(xlUp).Row + 1
    
28.     Cells(s2, 1).Resize(s, 7) = brr
    
29.     d.RemoveAll
    
30. Next
    
31. End Sub

复制代码

dsmch

………………

grf1973

凑个热闹

1. Sub tt()
   
2.     Dim brr(1 To 10000, 1 To 7)
   
3.     For Each sh In Worksheets     '遍历工作表获得成绩
   
4.         bj = sh.Name
   
5.         If bj <> ActiveSheet.Name Then
   
6.             arr = sh.[a2].CurrentRegion
   
7.             For i = 2 To UBound(arr)
   
8.                 n = n + 1
   
9.                 brr(n, 1) = bj
   
10.                 For j = 1 To UBound(arr, 2) - 1
    
11.                     brr(n, j + 1) = arr(i, j)
    
12.                 Next
    
13.             Next
    
14.         End If
    
15.     Next
    
16.     [a3].Resize(n, 7) = brr        '写入成绩
    
17.     [a3].Resize(n, 7).Sort key1:=[f3], order1:=xlDescending         '按总分倒序排列
    
18.     For p = 18 To n       '找和第15名同分的（p为第一个小于第15名成绩的行数）
    
19.         If Cells(p, 6) < Cells(15, 6) Then Cells(p, 1).Resize(10000, 7).ClearContents: Exit For
    
20.     Next
    
21.     For i = 3 To p - 1 '计算名次
    
22.         Cells(i, 7) = IIf(Cells(i, 6) = Val(Cells(i - 1, 6)), Cells(i - 1, 7), i - 2)
    
23.     Next
    
24. End Sub
    

复制代码

幻Θ影

dsmch 发表于 2015-3-24 10:25
………………

不行哦。。。

再个问题。1、我要的是两班一起排的，不是一班一班排。

2、有并列时取得太多了。。。例：如取前3，第二名有一个并列，本来是取一个1名，2个二名就行了。可是会取到第4名。

幻Θ影

grf1973 发表于 2015-3-24 14:51
凑个热闹

谢谢。。。不过最后一名有并列时不会两个都取。。

dsmch

………………