如何根据原始表关键列班级性别素质项目生成各项目各班统计表

yzyyyyyyy

原始表：关键列，班级，性别，各项目列

统计表：根据原始表生成各班，各性别，各项目人数 如何根据原始表关键列班级性别素质项目生成各项目各班统计表.rar (9.02 KB, 下载次数: 16)

2024-5-14 14:30 上传

点击文件名下载附件

蓝桥玄霜

统计的例子：

ooluckydog

yzyyyyyyy

蓝桥玄霜 发表于 2024-5-14 16:15
统计的例子：

感谢版主热心帮助，运行到 If d1(xx).exists(yy) Then，出现错误，麻烦有时间看一下，是哪抄错了，谢谢 如何根据原始表关键列班级性别素质项目生成各项目各班统计表.rar (17.8 KB, 下载次数: 9)

2024-5-15 10:59 上传

点击文件名下载附件

蓝桥玄霜

yzyyyyyyy 发表于 2024-5-15 10:58
感谢版主热心帮助，运行到 If d1(xx).exists(yy) Then，出现错误，麻烦有时间看一下，是哪抄错了，谢谢

xx = Brr(i, 1) & "|" & Brr(1, ii)
其中的"|"抄成了" |"  多了一个空格。

usedrange

Sub t()
    Dim arr, brr, i%, j%, dic, crr, spl, r%, m, c%
    arr = Sheets("原始表").UsedRange
    brr = Array("班级", "人数", "男", "女", "立定跳远", "坐位体前屈", "1分钟跳绳", "掷实心球", "1000米", "800米", "立定跳远", "坐位体前屈", "1分钟跳绳", "掷实心球", "1000米", "立定跳远", "坐位体前屈", "1分钟跳绳", "掷实心球", "800米")
    n = Sheets("原始表").Range("a65536").End(xlUp).Row
    r = WorksheetFunction.Max(Sheets("原始表").Range("a2:a" & n)) + 2
    ReDim crr(1 To r, 1 To 20)
    Set dic = CreateObject("scripting.dictionary")
    '初始化crr数组
    For i = 1 To UBound(crr)
        For j = 1 To UBound(crr, 2)
            crr(i, j) = 0
        Next j
    Next i
    '用字典统计各列数据
    For i = 2 To n
        dic(arr(i, 1)) = dic(arr(i, 1)) + 1
        dic(arr(i, 1) & "|" & arr(i, 4)) = dic(arr(i, 1) & "|" & arr(i, 4)) + 1
        For j = 10 To UBound(arr, 2)
            If arr(i, j) <> "" And j <> 12 Then
                dic(arr(i, 1) & "|" & arr(i, j)) = dic(arr(i, 1) & "|" & arr(i, j)) + 1
                dic(arr(i, 1) & "|" & arr(i, 4) & "|" & arr(i, j)) = dic(arr(i, 1) & "|" & arr(i, 4) & "|" & arr(i, j)) + 1
            End If
        Next j
    Next i
    '把各列标题赋值给crr
    c = 1
    For Each m In brr
        crr(1, c) = m
        c = c + 1
    Next m
    '从字典中取出各项统计数据放入crr数组中
    For Each k In dic.keys()
        If InStr(k, "|") Then
            spl = Split(k, "|")
            If UBound(spl) = 1 Then
                For m = 1 To 10
                    If spl(1) = crr(1, m) Then
                        crr(spl(0) + 1, m) = dic(k)
                    End If
                Next m
            ElseIf UBound(spl) = 2 Then
                If spl(1) = "男" Then
                    For m = 11 To 15
                        If spl(2) = crr(1, m) Then
                            crr(spl(0) + 1, m) = dic(k)
                        End If
                    Next m
                ElseIf spl(1) = "女" Then
                    For m = 16 To 20
                        If spl(2) = crr(1, m) Then
                            crr(spl(0) + 1, m) = dic(k)
                        End If
                    Next m
                End If
            End If
        Else
            crr(k + 1, 1) = k
            crr(k + 1, 2) = dic(k)
        End If
    Next k
    '统计合计项
    For i = 2 To UBound(crr, 2)
        If i = 2 Then crr(r, 1) = "合计"
        For j = 2 To UBound(crr) - 1
             crr(r, i) = crr(r, i) + crr(j, i)
        Next j
    Next i
    With Sheets("统计表")
        .[e11:j11].Merge
        .[e11] = "合计"
        .[k11:o11].Merge
        .[k11] = "男"
        .[p11:t11].Merge
        .[p11] = "女"
        '把crr数组放入统计表
        .[a12].Resize(UBound(crr), UBound(crr, 2)) = crr
    End With
    Set dic = Nothing
End Sub