谁能把这个成绩统计完善一下

狂毛

不喜欢太复杂的
1.加入年级排名和班级
2.缺考分数空的不计算平均分
3.优生率改为自定义分

FOB_FN_L

3.优生率改为自定义分  ------- "率" -------表达用词错误

3190496160

Sub 排名次()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("总成绩册")
    ws = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:i" & ws)
     .Range("a3:i" & ws) = Empty
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
            d(Trim(ar(i, 1))) = ""
        End If
    Next i
    For Each k In d.keys
        n = 0
        dc.RemoveAll
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For i = 3 To UBound(ar)
            If Trim(ar(i, 1)) = k Then
                n = n + 1
                dc(Trim(ar(i, 2))) = ""
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
        For i = 1 To n
            For s = i + 1 To n
                If br(i, 7) < br(s, 7) Then
                    For j = 1 To UBound(br, 2)
                        k1 = br(i, j)
                        br(i, j) = br(s, j)
                        br(s, j) = k1
                    Next j
                End If
            Next s
            br(i, 9) = i
        Next i
        For Each kc In dc.keys
            m = 0
            ReDim brr(1 To n, 1 To UBound(br, 2))
            For i = 1 To n
                If Trim(br(i, 2)) = kc Then
                    m = m + 1
                    For j = 1 To UBound(br, 2)
                        brr(m, j) = br(i, j)
                    Next j
                End If
            Next i
            For i = 1 To m
                For s = i + 1 To m
                    If brr(i, 7) < brr(s, 7) Then
                        For j = 1 To UBound(brr, 2)
                            k2 = brr(i, j)
                            brr(i, j) = brr(s, j)
                            brr(s, j) = k2
                        Next j
                    End If
                Next s
                brr(i, 8) = i
            Next i
            rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(rs, 1).Resize(m, UBound(brr, 2)) = brr
        Next kc
    Next k
End With
  MsgBox "OK!"
End Sub

3190496160

总成绩及统计表.rar (106.32 KB, 下载次数: 13)

2020-2-13 17:57 上传

点击文件名下载附件

FOB_FN_L

借用楼主的这个问题和附件，问个问题，如图如示，每个班级中间 如果保留几行的空行，然后排序班级的和年级的如何处理这个排序~~~中间的空行不删除就是用来区分开每个班级的隔档用

狂毛

3190496160 发表于 2020-2-13 10:33

运行有错误

chxw68

FOB_FN_L 发表于 2020-2-13 15:38
借用楼主的这个问题和附件，问个问题，如图如示，每个班级中间 如果保留几行的空行，然后排序班级的和年级 ...

删除空行排完序后再加上空行。

chxw68

FOB_FN_L 发表于 2020-2-13 15:38
借用楼主的这个问题和附件，问个问题，如图如示，每个班级中间 如果保留几行的空行，然后排序班级的和年级 ...

自己的问题最好开新贴，不要寄居在别人贴子中。

FOB_FN_L

chxw68 发表于 2020-2-13 16:37
自己的问题最好开新贴，不要寄居在别人贴子中。

和他这个问题相似，所以就借用楼主的问一下，您说的那种排完再加空行的就行了~~~只是想知道原格式不变的情况下怎么实现，空行删除再加那样我早就弄完了~~~~~~~

FOB_FN_L

chxw68 发表于 2020-2-13 16:22
删除空行排完序后再加上空行。

截图也是楼主的附件中的数据的，不是我的，只是在楼主的问题上提了个问题~~~~