求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

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