由成绩总表如何显示出每班单科前十名分数

vivian0526

由成绩总表如何显示出每班单科前十名分数

3190496160

这种问题，用vba代码来完成会好很多吧，可以灵活通用，
另外，如果用相同分数的，也是只取前十个吗？？

yfan17

B3=

1. =INDEX(理科成绩!$C:$C,MOD(-LARGE(IF(理科成绩!$A$2:$A$599=SUBSTITUTE(B$2,"班","")*1,理科成绩!$C$2:$C$599)*10^4-ROW($2:$599),ROW($A1)),10^3))

复制代码

xiangbaoan

VBA的.rar (116.94 KB, 下载次数: 15)

2021-10-25 17:44 上传

点击文件名下载附件

vivian0526

3190496160 发表于 2021-10-25 16:30
这种问题，用vba代码来完成会好很多吧，可以灵活通用，
另外，如果用相同分数的，也是只取前十个吗？？

是的，只要十个最高分。

vivian0526

xiangbaoan 发表于 2021-10-25 17:44

感谢，厉害~ 研究一下

vivian0526

yfan17 发表于 2021-10-25 17:29
B3=

谢谢，厉害的，学习一下~

洋务德雷

其实，楼主的主要问题还是基础数据源做的不规范。你的数据如果做成标准的一维表，那么不用公式，不用VBA，只要Excel的一些功能就可以做出结果来。

vivian0526

考试阅卷系统都不同，分数表形式也是什么样的都有。

3190496160

Sub 提取前w名()
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
w = InputBox("请输入要提取的名次", "名次", "10")
If w = "" Then Exit Sub
mc = Val(w)
With Sheets("理科成绩")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:ad" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(ar(i, 1)) = ""
    End If
Next i
Sheets("单科前十名（样表）").UsedRange = Empty
For j = 3 To 24 Step 3
    If Trim(ar(2, j)) <> "" Then
        m = 0: y = 1: sl = 0
        ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
        m = m + 1
        arr(m, 1) = Sheets("理科成绩").Cells(1, j)
        arr(2, 1) = "班级名次"
        For Each k In d.keys
            n = 0: y = y + 1: sl = sl + 1
            m = m + 1
            arr(2, y) = k & "班"
            m = 2
            ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
            For i = 2 To UBound(ar)
                If ar(i, 1) = k Then
                    n = n + 1
                    For jj = 1 To UBound(ar, 2)
                        br(n, jj) = ar(i, jj)
                    Next jj
                End If
            Next i
            For i = 1 To n
                For s = i + 1 To n
                    If IsNumeric(br(i, j)) And IsNumeric(br(s, j)) Then
                        If br(i, j) < br(s, j) Then
                            For ss = 1 To UBound(br, 2)
                                kk = br(i, ss)
                                br(i, ss) = br(s, ss)
                                br(s, ss) = kk
                            Next ss
                        End If
                    End If
                Next s
            Next i
            For i = 1 To n
                If i <= mc Then
                    If Trim(br(i, j)) <> "" Then
                        m = m + 1
                        If sl = 1 Then arr(m, 1) = i
                        arr(m, y) = br(i, j)
                    End If
                End If
            Next i
        Next k
        With Sheets("单科前十名（样表）")
            rs = .Cells(Rows.Count, 1).End(xlUp).Row + 2
            If rs = 3 Then
                rs = 1
            Else
                rs = rs
            End If
            .Cells(rs, 1).Resize(m, y) = arr
             .Cells(rs + mc + 2, 1) = "均分"
            For jj = 2 To y
                .Cells(rs + mc + 2, jj) = Application.Sum(.Range(.Cells(rs + 2, jj), .Cells(rs + 11, jj))) / 10
            Next jj
        End With
    End If
Next j
End Sub