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

戎马书生222

要求：

1、在工作表“成绩”中，在每个学科右边插入一列“学科的级名次”，从语文到地理，并计算出班名次和校名次。
2、在工作表“一分一段”中，实现从第1名开始，每50名一个分数段，统计出名次段内的各班级人数。直至最后一个名次的名次段。
3、工作表“成绩”中的，R列--T列是各学科和总成绩的普本分数线和一批分数线。总分的普本分数线表示总分高于此分数线的话，就进入普本范围。学科的类似。比如语文考了120分，就说明语文过了语文学科的一批分数线。

在此先谢谢论坛里的高手了。平常用数据透视表，由于每次考试的人数不同，必须更改数据源，还得刷新，比较麻烦。求高手用VBA解决，谢谢了！

dragonthree

工作量有点大吧！！！

3190496160

Sub 成绩分析()
Application.ScreenUpdating = False
Dim ar 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))
End With
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) + 1)
        For jj = 1 To UBound(rr, 2)
            br(1, jj + 1) = rr(1, jj)
        Next jj
        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
                    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
        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
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

123.rar (167.85 KB, 下载次数: 33)

2024-6-6 10:37 上传

点击文件名下载附件

3190496160

所有分析数据都放到一个工作表内，
名次段的设置，不是非常明白楼主的意思，目前的思路是在名次段工作表的第一行设置，仅供参考

戎马书生222

3190496160 发表于 2024-6-6 10:39
所有分析数据都放到一个工作表内，
名次段的设置，不是非常明白楼主的意思，目前的思路是在名次段工作表的 ...

正在外地考试，10号之后回复大侠。谢谢了。

chxw68

楼主模拟结果不正确吧！50名一个名次段，那么每个名次段人数都应该是50人左右。

魂断蓝桥

这个最好使用数据库来实现，sqlite里有窗口函数做这个比较容易一些

先做一个排名的。

因为用到了sqlite数据库，需要先下载一个dll来实现。
网址：http://www.vbrichclient.com/#/en/Downloads.htm












班级排名，年级排名代码


Option Explicit
Sub a()
    Dim cnn As New cConnection
    Dim rs As New cRecordset
    Dim sql$, s, arr, I, J, m, myf
    Application.ScreenUpdating = False
    Sheets("成绩").Activate
    m = [A9999].End(3).Row
    arr = Range("A1").CurrentRegion
    For I = UBound(arr, 2) To 3 Step -1
        If arr(1, I) Like "*名次" Then
            s = Replace(Cells(1, I).Address(0, 0), 1, "")
            Columns(s).Delete
        End If
    Next
    myf = ThisWorkbook.FullName
    cnn.CreateNewDB
    sql = "CREATE TABLE T(考号,班级,姓名,科目,成绩)"
    cnn.Execute sql
    cnn.BeginTrans
    For I = 2 To UBound(arr)
        For J = 4 To UBound(arr, 2) - 3
            s = arr(I, 1) & ",'" & arr(I, 2) & "','" & arr(I, 3) & "','" & arr(1, J) & "'," & arr(I, J)
            sql = "INSERT INTO T VALUES(" & s & ")"
            cnn.Execute sql
        Next
    Next
    cnn.CommitTrans
    arr = Array("语文", "数学", "英语", "日语", "西语", "物理", "化学", "生物", "政治", "历史", "地理", "总分")
    For I = 0 To UBound(arr)
        J = I * 3 + 4
        Range("a1:b" & m).Offset(0, J).Insert Shift:=xlToRight
        sql = "SELECT RANK() OVER (PARTITION BY 班级 ORDER BY 班级,成绩 DESC)  AS 班名次," _
        & "RANK() OVER (ORDER BY 成绩 DESC)  AS 校名次 FROM T WHERE 科目='" & arr(I) & "' ORDER BY 考号"
        rs.OpenRecordset sql, cnn
        Range("a2").Offset(0, J).CopyFromRecordset rs.GetADORsFromContent
        Range("a1").Offset(0, J) = arr(I) & "_班名次"
        Range("a1").Offset(0, J + 1) = arr(I) & "_校名次"
    Next
    Set rs = Nothing
    Set cnn = Nothing
    Application.ScreenUpdating = True
End Sub

魂断蓝桥

全部代码已经做好了。

就现有的数据，在我的电脑上用时不超过0.5秒

区间表
因数据比较少，就按照10名一组计算



分数线表






全部代码


Option Explicit
Sub A()
    Dim cnn As New cConnection
    Dim rs As New cRecordset
    Dim sql$, S, arr, I, J, m, myf As String, D1, D2, BRR, CRR, t, s1
    Dim mytim
    mytim = Timer
    Application.ScreenUpdating = False
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
    Sheets("成绩").Activate
    arr = Range("A1").CurrentRegion
    For I = UBound(arr, 2) To 3 Step -1
        If arr(1, I) Like "*名次" Then
            S = Replace(Cells(1, I).Address(0, 0), 1, "")
            Columns(S).Delete
        End If
    Next
    arr = Range("A1").CurrentRegion
    CRR = Range("P2:R13")
    m = UBound(arr)
    myf = ThisWorkbook.Path & "\T.DB"
    cnn.CreateNewDB
    sql = "CREATE TABLE T(考号,班级,姓名,科目,成绩)"
    cnn.Execute sql
    cnn.BeginTrans
    For I = 2 To UBound(arr)
        For J = 4 To UBound(arr, 2) - 3
            S = arr(I, 1) & ",'" & arr(I, 2) & "','" & arr(I, 3) & "','" & arr(1, J) & "'," & arr(I, J)
            sql = "INSERT INTO T VALUES(" & S & ")"
            cnn.Execute sql
        Next
    Next
    cnn.CommitTrans
    arr = Array("语文", "数学", "英语", "日语", "西语", "物理", "化学", "生物", "政治", "历史", "地理", "总分")
    For I = 0 To UBound(arr)
        J = I * 3 + 4
        Range("a1:b" & m).Offset(0, J).Insert Shift:=xlToRight
        sql = "SELECT RANK() OVER (PARTITION BY 班级 ORDER BY 班级,成绩 DESC)  AS 班名次," _
        & "RANK() OVER (ORDER BY 成绩 DESC)  AS 校名次 FROM T WHERE 科目='" & arr(I) & "' ORDER BY 考号"
        rs.OpenRecordset sql, cnn
        Range("a2").Offset(0, J).CopyFromRecordset rs.GetADORsFromContent
        Range("a1").Offset(0, J) = arr(I) & "_班名次"
        Range("a1").Offset(0, J + 1) = arr(I) & "_校名次"
    Next
    sql = "CREATE TABLE 区间 (下限,上限,组)"
    cnn.Execute sql
    cnn.BeginTrans
    For I = 0 To 9
        sql = "INSERT INTO 区间 VALUES(" & I * 10 + 1 & "," & I * 10 + 10 & ",'" & I * 10 + 1 & "-" & I * 10 + 10 & "名')"
        cnn.Execute sql
    Next
    sql = "CREATE TABLE 分数线 (科目, 普本线, 高分线)"
    cnn.Execute sql
    For I = 1 To UBound(CRR)
        sql = "INSERT INTO 分数线 VALUES('" & CRR(I, 1) & "'," & CRR(I, 2) & "," & CRR(I, 3) & ")"
        cnn.Execute sql
    Next
    cnn.CommitTrans
    sql = "SELECT 班级,科目,组,COUNT(*) AS 人数 FROM ( SELECT A.*,B.组 FROM (" _
    & "SELECT 班级,科目,成绩,RANK() OVER (PARTITION BY 班级,科目 ORDER BY 班级,科目,成绩 DESC)  AS 班名次 FROM t ) A " _
    & "LEFT JOIN 区间 B ON A.班名次 BETWEEN B.下限 AND B.上限) GROUP BY 班级,科目,组"
    rs.OpenRecordset sql, cnn
    BRR = rs.GetRows
    For J = 0 To UBound(BRR, 2)
        s1 = BRR(0, J) & BRR(1, J) & BRR(2, J)
        D1(s1) = BRR(3, J)
    Next
    sql = "SELECT 班级,科目,SUM(普本人数) as 普本人数,SUM(高分人数) AS 高分人数 FROM (" _
    & " SELECT 班级,T.科目 AS 科目,成绩,成绩>=普本线 AS 普本人数,普本线,成绩>=高分线 AS 高分人数,高分线 FROM T " _
    & " LEFT JOIN 分数线 ON t.科目=分数线.科目) GROUP BY 班级,科目"
    rs.OpenRecordset sql, cnn
    BRR = rs.GetRows
    For J = 0 To UBound(BRR, 2)
        s1 = BRR(0, J) & BRR(1, J)
        D2(s1) = BRR(2, J) & "|" & BRR(3, J)
    Next
    Set rs = Nothing
    Set cnn = Nothing
    Sheets("一分一段").Activate
    For I = 3 To 73 Step 6
        Cells(I, 3).Resize(5, 12) = ""
    Next
    arr = [a1].CurrentRegion
    For I = 3 To UBound(arr)
        If arr(I, 1) <> "合计" And arr(I, 1) <> "班级" Then
            t = arr(I, 2)
            If t <> "" Then
            Else
                arr(I, 2) = arr(I - 1, 2)
                t = arr(I, 2)
            End If
            For J = 3 To UBound(arr, 2) - 1
                If J <= 12 Then
                    S = arr(I, 1) & t & arr(2, J)
                    arr(I, J) = D1(S)
                Else
                    S = arr(I, 1) & t
                    arr(I, J) = Split(D2(S), "|")(0)
                    arr(I, J + 1) = Split(D2(S), "|")(1)
                End If
            Next
        End If
    Next
    [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    For I = 3 To 73 Step 6
        Cells(I + 4, 3).Resize(1, 12).FormulaR1C1 = "=SUM(R[-4]C:R[-1]C)"
    Next
    Set D1 = Nothing
    Set D2 = Nothing
    Application.ScreenUpdating = True
    MsgBox Format(Timer - mytim, "0.00")
End Sub



123.rar (66.24 KB, 下载次数: 11)

2024-6-7 12:11 上传

点击文件名下载附件

戎马书生222

chxw68 发表于 2024-6-6 15:46
楼主模拟结果不正确吧！50名一个名次段，那么每个名次段人数都应该是50人左右。

最好用美式排名。要不像物理，满分只有100分，最多100个名次。只有美式排名，才能像大侠说的。1-50名，应该是50个人左右。要是中式排名的话，1-50名，人数可能上百人。