求vba成绩分数段统计

EHGOOD

参与一下。

limonet

关键字：uunion all+transform

limonet

Sub limonet()
    Application.DisplayAlerts = False
    Dim Cn As Object, StrSQL$, Arr As Variant, i%
    Arr = Sheets("得分").Range("C1:F1")
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    For i = 1 To UBound(Arr, 2)
        StrSQL = StrSQL & " Union All Select 班级,'" & Arr(1, i) & "' as 学科," & Arr(1, i) & " as 分数,Partition(" & Arr(1, i) & "-0.5,60,89,10) as 分段 From [得分$B:F] Where 班级<>''"
    Next i
    StrSQL = "TransForm Count(*) Select 学科,班级 From (" & Mid(StrSQL, 12) & ") Group By 班级,学科 Order By 学科 Pivot 分段 "
    Range("A3").CopyFromRecordset Cn.Execute(StrSQL)
    For i = 34 To 2 Step -1
        If Cells(i, "A") = Cells(i - 1, "A") Then Range("A" & i - 1).Resize(2, 1).Merge
    Next i
    Application.DisplayAlerts = True
End Sub

牛牛神哦

你好，请查看附件，应该可以解决你的问题，包含在“得分”表格中增加新的数据。有问题再沟通。

17687589358

完成！..........

458863601

EHGOOD 发表于 2024-4-11 17:53
参与一下。

我想改一下表格，有空帮我看看吗？

chxw68

458863601 发表于 2024-5-28 11:02
我想改一下表格，有空帮我看看吗？

我看问题都已经解决了！还有什么问题吗？

458863601

chxw68 发表于 2024-5-28 15:16
我看问题都已经解决了！还有什么问题吗？

老师，如何把学生的姓名和成绩写进写进分数段统计出来的个数的单元格备注里？

不规则结构

这帮老师真是为师不尊，要将白嫖进行到底啊！！！！论坛里最多就是这帮为人师表不足误人子弟的“老师”！

魂断蓝桥

Option Explicit
Sub a()
    Dim cnn, myf$, SqA$, rs, i, j, arr, brr(1 To 9999, 1 To 2), Sql As String, d, S, M, T, S1 As String
    Set d = CreateObject("Scripting.Dictionary")
    Set cnn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.Recordset")
    myf = ThisWorkbook.FullName
    Set cnn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.Recordset")
    Application.ScreenUpdating = False
    cnn.Open "Provider=Microsoft.ACE.OleDb.12.0;Extended Properties='Excel 12.0;HDR=YES'; Data Source=" & myf
    Sql = "select 年级,班级,'语文' AS 科目,语文 AS 成绩,姓名 FROM [得分$A1:Q] where 姓名 is not null UNION ALL " _
    & " select 年级,班级,""数学"" AS 科目,数学 AS 成绩,姓名 FROM [得分$A1:Q] where 姓名 is not null UNION ALL " _
    & " select 年级,班级,""英语"" AS 科目,英语 AS 成绩,姓名 FROM [得分$A1:Q] where 姓名 is not null UNION ALL " _
    & " select 年级,班级,""道法"" AS 科目,道法 AS 成绩,姓名 FROM [得分$A1:Q]  where 姓名 is not null"
    Sql = "SELECT 年级,班级,科目,姓名,成绩,SWITCH(成绩<=9.9,'J', 成绩<=19.9,'I',成绩<=29.9,'H',成绩<=39.9,'G',成绩<=49.9,'F'," _
    & "成绩<=59.9,'E',成绩<=69.9,'D',成绩<=79.9,'C', 成绩<=89.9,'B', 成绩<=120,'A') AS 等级 FROM (" & Sql & ") "
    SqA = "SELECT 年级,科目,班级,等级,姓名,成绩 FROM (" & Sql & ")"
    Sql = "SELECT 班级,科目,等级,COUNT(*) AS 计次 FROM (" & Sql & ") WHERE 等级 IS NOT NULL GROUP BY 班级,科目,等级"
    Sql = "transform first(计次) select 科目,班级 from (" & Sql & ") group by 科目,班级 pivot 等级"
    Sheets("汇总").Activate
    [A3:L14] = ""
    Range("A3").CopyFromRecordset cnn.Execute(Sql)
    rs.Open SqA, cnn, 1, 1
    arr = rs.GetRows
    Set rs = Nothing
    Set cnn = Nothing
    For j = 0 To UBound(arr, 2)
        S = arr(1, j) & arr(2, j) & arr(3, j)
        If Not d.Exists(S) Then
            M = M + 1
            d(S) = M
            brr(d(S), 1) = S
            brr(d(S), 2) = arr(4, j) & " " & arr(5, j)
        Else
            brr(d(S), 2) = brr(d(S), 2) & "@" & arr(4, j) & " " & arr(5, j)
        End If
    Next
    d.RemoveAll
    For j = 1 To M
        d(brr(j, 1)) = brr(j, 2)
    Next
    arr = [a1].CurrentRegion
    Columns("C:L").ClearNotes
    For i = 3 To UBound(arr)
        If arr(i, 1) <> "" Then
            T = arr(i, 1)
        Else
            T = arr(i - 1, 1)
            arr(i, 1) = T
        End If
        For j = 3 To UBound(arr, 2)
            S = T & arr(i, 2) & Left(arr(2, j), 1)
            S1 = Replace(d(S), "@", vbCrLf)
            If d(S) <> "" Then Cells(i, j).AddComment S1
        Next
    Next
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub