vba按字典多条件统计分组班级平均分

·遁去的一·

近百万数据没问题啊

lcmphy

·遁去的一· 发表于 2022-11-19 00:02
近百万数据没问题啊

是的，并且还与电脑配置也有关系，考虑不周，用词不妥，误会chxw68了。再次感谢chxw68！

lcmphy

chxw68 发表于 2022-11-18 17:25
代码速度太慢，故删除。

测试数据量大，还与我电脑用了多年配置早就过时有很大关系，表述欠妥，引起误解了，对不起啊！已经很好解决我的求助了。借用您的签名，请多包涵。

lcmphy

chxw68 发表于 2022-11-18 17:24

非常感谢您的帮助！一直在用您当时因误会根据15楼附件写好又删除的代码，可以在参考人数后加一列各班最高分么？最高分不需要排名，接下来的平均分与平均分排名继续保留，同样适合多个组别、多个班级、多个科目。
原有代码如下：
Sub test()
    Dim r%, i%
    Dim arr, brr
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    With Worksheets("sheet1")
        r = .Cells(.Rows.Count, 1).End(xlUp).Row
        c = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range("a1").Resize(r, c)
    End With
    For j = 7 To UBound(arr, 2)
        If Application.Count(Application.Index(arr, 0, j)) <> 0 Then
            Set d(arr(1, j)) = CreateObject("scripting.dictionary")
            For i = 2 To UBound(arr)
                If Len(arr(i, j)) <> 0 Then
                    If Not d(arr(1, j)).exists(arr(i, 1)) Then
                        Set d(arr(1, j))(arr(i, 1)) = CreateObject("scripting.dictionary")
                    End If
                    If Not d(arr(1, j))(arr(i, 1)).exists(arr(i, 3)) Then
                        ReDim brr(1 To 5)
                        brr(1) = arr(i, 1)
                        brr(2) = arr(i, 3)
                    Else
                        brr = d(arr(1, j))(arr(i, 1))(arr(i, 3))
                    End If
                    brr(3) = brr(3) + 1
                    brr(4) = brr(4) + arr(i, j)
                    d(arr(1, j))(arr(i, 1))(arr(i, 3)) = brr
                End If
            Next
        End If
    Next
    With Worksheets("统计")
        .Cells.Clear
        n = 1
        For Each aa In d.keys
            With .Cells(1, n)
                .Value = aa
                .Resize(1, 5).Merge
                With .Font
                    .Name = "微软雅黑"
                    .Size = 11
                    .Bold = True
                End With
            End With
            With .Cells(2, n).Resize(1, 5)
                .Value = Array("科类", "班级", "参考人数", "平均分", "排名")
                .Borders.LineStyle = xlContinuous
                .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
                With .Font
                    .Name = "微软雅黑"
                    .Size = 11
                    .Bold = True
                End With
            End With
            r = 3
            For Each bb In d(aa).keys
                d1.RemoveAll
                ReDim crr(1 To d(aa)(bb).Count + 1, 1 To 5)
                crr(UBound(crr), 2) = "合计"
                m = 0
                For Each cc In d(aa)(bb).keys
                    brr = d(aa)(bb)(cc)
                    m = m + 1
                    For j = 1 To UBound(brr)
                        crr(m, j) = brr(j)
                    Next
                    For j = 3 To 4
                        crr(UBound(crr), j) = crr(UBound(crr), j) + brr(j)
                    Next
                Next
                For i = 1 To UBound(crr)
                    If Len(crr(i, 3)) <> 0 And crr(i, 3) <> 0 Then
                        crr(i, 4) = Application.Round(crr(i, 4) / crr(i, 3), 2)
                    End If
                Next
                For i = 1 To UBound(crr) - 1
                    If Len(crr(i, 4)) <> 0 Then
                        d1(crr(i, 4)) = d1(crr(i, 4)) + 1
                    End If
                Next
                nn = 1
                kk = d1.keys
                For k = 0 To UBound(kk)
                    mm = Application.Large(kk, k + 1)
                    ss = d1(mm)
                    d1(mm) = nn
                    nn = nn + ss
                Next
                For i = 1 To UBound(crr) - 1
                    If Len(crr(i, 4)) <> 0 Then
                        crr(i, 5) = d1(crr(i, 4))
                    End If
                Next
                With .Cells(r, n).Resize(UBound(crr), UBound(crr, 2))
                    .Value = crr
                    .Borders.LineStyle = xlContinuous
                    .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
                    With .Font
                        .Name = "微软雅黑"
                        .Size = 11
                    End With
                End With
                .Cells(r, n).Resize(UBound(crr), 1).Merge
                r = r + UBound(crr)
            Next
            n = n + 6

        Next
        With .UsedRange
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With

End Sub

lcmphy

lcmphy 发表于 2025-12-11 15:57
非常感谢您的帮助！一直在用您当时因误会根据15楼附件写好又删除的代码，可以在参考人数后加一列各班最高分 ...

不要好意思，是19楼的附件。

chxw68

修改好了。

lcmphy

chxw68 发表于 2025-12-11 17:40
修改好了。

非常感谢chxw68的帮助！非常完美