求助：用VBA提取数据并进行排名

wuchengde

需求：选择考试年级后，点击【统计成绩】按钮，根据所选的年级，以“mb”为模板，新建一个工作表，并命名为“成绩总表(一年级),新建工作表代码已经写好了，接着获取工作表“原始成绩”中的年级数据，按mb需要的内容进行统计。

备注：一、二年级只考语文、数学，三—六年级考所有科目。因此当选择的是一、二年级时，要删除“英语、科学、品德”三科的统计。

具体请看附件。

wuchengde

补传附件，希望各位高手帮忙解决，非常感谢！

不知道为什么

wuchengde 发表于 2019-4-19 18:11
补传附件，希望各位高手帮忙解决，非常感谢！

论坛类似成绩处理的帖子实在太多了，不知道楼主搜索了没有？

wuchengde

不知道为什么 发表于 2019-4-19 18:17
论坛类似成绩处理的帖子实在太多了，不知道楼主搜索了没有？

我已经搜了很多的了，然后尝试改了很多次，可是都达不到效果，才来请求帮助的！
本论坛的几个相似的帖子如下：http://club.excelhome.net/thread-1215025-1-1.html
http://club.excelhome.net/thread-689873-1-1.html
http://club.excelhome.net/thread-1353197-1-1.html
还有其他论坛的帖子、百度的问答，都看了，但由于对字典的的使用和排名方式不太熟悉，所做不出我想要的效果啊！

还请各位多多帮助。

wuchengde

Sheets.Add
ActiveSheet.Name = s
Sheets(s).Activate
Cells.clear
If Sheets(r).[g2] = "中国式排名" Then fs = 1 Else fs = 2
arr = Sheets(r).[a1].CurrentRegion
For i = 4 To UBound(arr)
    d(arr(i, 3)) = d(arr(i, 3)) & i & ","
Next
k = d.keys: t = d.items
brr = Sheets(r).[a4].Resize(UBound(arr) - 3, UBound(arr, 2))
With Sheets("基本信息设置")
    [a1] = .Range("d2") & .Range("d3") & .Range("d4") & .Range("d5") & .Range("d6") & "成绩统计表"
End With
For j = 1 To 4
    Cells(2, j) = arr(3, j)                                             '标题前四列
    Cells(3, j).Resize(UBound(brr), 1) = Application.Index(brr, 0, j)   '前四列基本信息
Next
For j = 5 To UBound(arr, 2)
    Cells(2, 3 * j - 10) = arr(3, j)                                                 '科目标题
    Call bp(j, fs)
    Cells(2, 3 * j - 8) = arr(3, j) & vbLf & "班排"                                          '班排标题
    Cells(3, 3 * j - 10).Resize(UBound(brr), 1) = Application.Index(brr, 0, j)       '原成绩数据
    Call np(j, fs)
    Cells(2, 3 * j - 9) = arr(3, j) & vbLf & "年排"                                         '年排标题
    Cells(3, 3 * j - 9).Resize(UBound(brr), 1) = [bc1].Resize(UBound(brr), 1).Value  '年排数据
Next
[ba:bc].clear
Myc = [iv2].End(xlToLeft).Column
Cells(2, Myc + 1) = "进退" & vbLf & "情况"

'计算进退情况
Dim carr
If Len(ss) <> 0 Then
    With Sheets(ss)
        ssrr = .Range("a1").CurrentRegion
    End With
    With Sheets(s)
        srr = .Range("a1").CurrentRegion
        ReDim carr(1 To UBound(srr) - 2, 1 To 1)
        For m = 1 To UBound(srr) - 2
            For n = 3 To UBound(ssrr)
                If .Cells(m + 2, 1) = Sheets(ss).Cells(n, 1) Then
                    carr(m, 1) = Sheets(ss).Cells(n, UBound(ssrr, 2) - 2) - .Cells(m + 2, UBound(srr, 2) - 2)
                    Exit For
                Else
                    carr(m, 1) = "-"
                End If
            Next n
        Next m
        .Cells(3, UBound(srr, 2)).Resize(UBound(carr), 1) = carr
    End With
Else
    With Sheets(s)
        srr = .Range("a1").CurrentRegion
        ReDim carr(1 To UBound(srr) - 2, 1 To 1)
        .Cells(3, UBound(srr, 2)).Resize(UBound(carr), 1) = "-"
    End With
End If

With [a1].Resize(1, Myc + 1)
    .Merge
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Size = 18
    .Font.Bold = True
End With
[a1].CurrentRegion.Borders.LineStyle = 1

'对成绩进行排序
mrr = Sheets(s).[a1].CurrentRegion
Set Rng = Range("a2:az" & UBound(mrr))
'rng.Sort Key1:="考号", Order1:=xlAscending, Header:=xlYes   '以准考证号进行升序排序
Rng.Sort Key1:="总分", Order1:=xlDescending, Header:=xlYes      '以总分进行降序排序

Set d = Nothing
MsgBox "本次成绩统计已完成！" & Chr(13) & Chr(13) & "总运行时间为：" & Timer - tim & " 秒！"

End Sub

Sub np(j, fs)
'年排
Dim i&, crr, n%
[ba:bc].clear
[ba1] = 1: [ba2] = 2: [ba1:ba2].AutoFill [ba1].Resize(UBound(brr), 1)
[bb1].Resize(UBound(brr), 1) = Application.Index(brr, 0, j)
[ba1].Resize(UBound(brr), 2).Sort [bb1], 2, Header:=xlNo
crr = [ba1].Resize(UBound(brr), 2)
[bc1] = 1: n = 1
For i = 2 To UBound(crr)
    If crr(i, 2) < crr(i - 1, 2) Then
        n = n + 1
        If fs = 2 Then
            Cells(i, "bc") = i
        Else
            Cells(i, "bc") = n
        End If
    Else
        Cells(i, "bc") = Cells(i - 1, "bc").Value
    End If
Next
[ba1].Resize(UBound(brr), 3).Sort [ba1], 1, Header:=xlNo
End Sub

Sub bp(j, fs)
'班排
Dim i&, crr, aa, y&, ii&, tt, n%        'y=56               ii=57
For i = 0 To UBound(k)                  'UBound(k)=11
    [ba:bc].clear
    tt = t(i)
    tt = Left(tt, Len(tt) - 1)
    If InStr(tt, ",") Then
        aa = Split(tt, ",")
        For y = 0 To UBound(aa)
            Cells(y + 1, "ba") = aa(y)
            Cells(y + 1, "bb") = arr(aa(y), j)
        Next
        [ba1].Resize(UBound(aa) + 1, 2).Sort [bb1], 2, Header:=xlNo
        crr = [ba1].Resize(UBound(aa) + 1, 2)
        [bc1] = 1: n = 1
        For ii = 2 To UBound(crr)
            If crr(ii, 2) < crr(ii - 1, 2) Then
                n = n + 1
                If fs = 2 Then
                    Cells(ii, "bc") = ii
                Else
                    Cells(ii, "bc") = n
                End If
            Else
                Cells(ii, "bc") = Cells(ii - 1, "bc").Value
            End If
        Next
        [ba1].Resize(UBound(aa) + 1, 3).Sort [ba1], 1, Header:=xlNo
        For y = 0 To UBound(aa)
           Cells(aa(y) - 1, 3 * j - 8) = Cells(y + 1, "bc").Value
        Next
    Else
        Cells(1, "ba") = 1
        Cells(1, "bb") = brr(tt, j)
        Cells(1, "bc") = 1
        Cells(tt, 3 * j - 8) = 1
    End If
Next
End Sub

这是之前蓝版主也帮我做过一次，可是那个只是一个学校的，只有班级和年级的排名，这次这个加入各学校，我拿蓝版主的来研究半天，看不懂后面的班排和年排的代码啊。

longkkkk

工作量有点大啊，兄弟

wuchengde

longkkkk 发表于 2019-4-19 20:41
工作量有点大啊，兄弟

哎，没办法啊，为了工作，这个只是其中的一个，其他的相对不太复杂的，我在使用低级的处理方法慢慢的做呢，只要能达到效果，管不了那么多了

longkkkk

如果只是选择一年级，是否只要计算所有一年级的学生总分、各科的各项进行排名，而对于学生的排序没有要求吗？

wuchengde

longkkkk 发表于 2019-4-19 21:20
如果只是选择一年级，是否只要计算所有一年级的学生总分、各科的各项进行排名，而对于学生的排序没有要求吗 ...

是的，只统计所选年级的，其他不用管，排序排不排都没关系，排序我可以根据总分进行排的，要是能一起考虑进去，一起做了那更好。

mjzxlmg

关键是这种没有规律的表格写出来的代码通用性不强呀。同是科目，语文跟其它科目不同， 科目顺序乱了判断太麻烦。