求助高手实现类似数据透视表的功能

戎马书生222

魂断蓝桥 发表于 2024-6-12 10:27

感谢大侠的设计。名次好像存在错误。
1、班名次是指该学生的总分在本班内的排名。语名是该生语文分数在全校语文成绩中的排名。数学、英语、物理、化学、日语、西语、生物、政治、历史、地理的名次也是该学生的成绩在全校中的排名。
2、排名要采用美式排名。要是中式排名会出现1-50名分数段有100多人的现象。
3、“组合内名次”是指该学生的成绩在他所属的组合，比如“物化地”内所有人成绩中的排名。

戎马书生222

3190496160 发表于 2024-6-12 08:30
呵呵，按你在一楼中说的，再结合你的附件，需要统计的名次段应该是互相不存在交集的吧，如果你前面已近有 ...

大型考试的普本线，像我这边都是普本线是全县3000名的成绩，一本线是全县1200名的成绩。
所以在工作表里设置统计1-1200，不就相当于统计了班级的普本人数了吗？

戎马书生222

戎马书生222 发表于 2024-6-12 15:01
感谢大侠的设计。名次好像存在错误。
1、班名次是指该学生的总分在本班内的排名。语名是该生语文分数在 ...

图中的语文名次就不对了。126分对应的是第1名，107分对应的也是第1名

3190496160

按这样的思路设计出一个表格上传，也许可以考虑再修改一下代码

魂断蓝桥

已经修改好。
aa.rar (177.4 KB, 下载次数: 4)

2024-6-12 16:08 上传

点击文件名下载附件

3190496160

Sub 成绩分析()
Application.ScreenUpdating = False
Dim ar As Variant, arr As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set sh = Sheets("成绩")
r = sh.Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "成绩表为空！": End
With Sheets("名次段")
    y = .Cells(1, Columns.Count).End(xlToLeft).Column
    If y = 1 Then MsgBox "名次段为空！": End
    rr = .Range(.Cells(1, 1), .Cells(1, y))
    arr = .Range("a4:m6")
End With
For j = 2 To 13
    dc(arr(1, j)) = j
Next j
ar = sh.Range("a1:n" & r)
With Sheets("分析数据")
    .UsedRange.Borders.LineStyle = 0
    .UsedRange = Empty
    For j = 3 To 14
        k = 1: d.RemoveAll
        ReDim br(1 To UBound(ar), 1 To UBound(rr, 2) + 3)
        For jj = 1 To UBound(rr, 2)
            br(1, jj + 1) = rr(1, jj)
        Next jj
        br(1, 1) = "班级"
        br(1, UBound(br, 2) - 1) = "[ " & ar(1, j) & " ]" & "普本上线人数"
        br(1, UBound(br, 2)) = "[ " & ar(1, j) & " ]" & "一本上线人数"
        lh = dc(ar(1, j))
        pb = arr(2, lh)
        yb = arr(3, lh)
        For i = 2 To UBound(ar)
            If ar(i, 1) <> "" Then
                t = d(ar(i, 1))
                If t = "" Then
                    k = k + 1
                    d(ar(i, 1)) = k
                    t = k
                    br(k, 1) = ar(i, 1)
                End If
                If ar(i, j) <> "" Then
                    If IsNumeric(ar(i, j)) Then
                        mc = Application.Rank(ar(i, j), sh.Range(sh.Cells(2, j), sh.Cells(r, j)))
                        For s = 1 To UBound(rr, 2) - 1
                            ks = Val(Split(rr(1, s), "-")(0))
                            js = Val(Split(rr(1, s), "-")(1))
                            If mc >= ks And mc <= js Then
                                br(t, s + 1) = br(t, s + 1) + 1
                                'Exit For
                            End If
                        Next s
                        If ar(i, j) >= pb Then br(t, UBound(br, 2) - 1) = br(t, UBound(br, 2) - 1) + 1
                        If ar(i, j) >= yb Then br(t, UBound(br, 2)) = br(t, UBound(br, 2)) + 1
                    End If
                End If
            End If
        Next i
        rs = .Cells(Rows.Count, 1).End(xlUp).Row + 2
        If rs = 3 Then rs = 1
        .Cells(rs, 1) = ar(1, j)
        .Cells(rs + 1, 1).Resize(k, UBound(br, 2)) = br
        x = rs + k + 1
        For i = rs + 2 To x - 1
            .Cells(i, UBound(rr, 2) + 1) = Application.Sum(.Range(.Cells(i, 2), .Cells(i, UBound(rr, 2))))
        Next i
        .Cells(x, 1) = "总计"
        For jj = 2 To UBound(rr, 2) + 1
            .Cells(x, jj) = Application.Sum(.Range(.Cells(rs + 2, jj), .Cells(x - 1, jj)))
        Next jj
        .Cells(rs + 1, 1).Resize(k + 1, UBound(br, 2)).Borders.LineStyle = 1
    Next j
    .Columns("a:v").AutoFit
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

123.rar (173.63 KB, 下载次数: 5)

2024-6-12 17:16 上传

点击文件名下载附件

3190496160

在 名次段工 作表内事先设定各个科目和总分的普本上线，一本上线分数，

戎马书生222

3190496160 发表于 2024-6-12 16:02
按这样的思路设计出一个表格上传，也许可以考虑再修改一下代码

太感谢了。
在工作表“名次段”，要是能用50代替“1-49”来表示名次<=50的就好了。
原因是若是用“1-49”来表示，导致表格的列太宽了，一屏显示的列的内容太少了。

戎马书生222

魂断蓝桥 发表于 2024-6-12 16:08
已经修改好。

9班语文名次前50名一共才14个人，统计表里50人