统计课时和班级数

[vb]代码库

Sub 统计全部()
    Dim arr, arr1(), brr, crr, drr, err(), frr()
    Dim i, j, k, x, y, n, m
    Dim rng As Range, rng1 As Range
    Dim d As Object, d1 As Object, d2 As Object
    Dim str As String
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    drr = [{"高一","高二","高三"}]
    For i = LBound(drr) To UBound(drr)
        Set rng = Sheets(drr(i)).UsedRange
        x = rng.Range("f5").CurrentRegion.Rows.Count
        y = rng.Range("f5").CurrentRegion.Columns.Count
        For Each rng1 In rng
            If drr(i) = "高一" Then
                If rng1 = "班级" Then
                    arr = rng1.CurrentRegion '教师数组
                End If
                If rng1 = "课时" Then
                    brr = rng1.CurrentRegion '课时数组
                End If
            Else
                If rng1 = "班级" Then
                    arr = Range(rng1.CurrentRegion.Cells(1, 2), rng1.CurrentRegion.Cells(x, y)) '教师数组,去掉首列
                End If
                If rng1 = "课时" Then
                    brr = Range(rng1.CurrentRegion.Cells(1, 2), rng1.CurrentRegion.Cells(x, y)) '课时数组,去掉首列
                End If
            End If
        Next
        k = k + UBound(arr, 2) '计算重定义数组的列数
        '将数据全部放入数组err和frr
        ReDim Preserve err(1 To UBound(arr), 1 To k)
        ReDim Preserve frr(1 To UBound(arr), 1 To k)
        For m = 1 To UBound(arr, 2)
            n = n + 1 '计数累加
            For j = 1 To UBound(arr)
                err(j, n) = arr(j, m)
                frr(j, n) = brr(j, m)
            Next
        Next
    Next
    '写入字典去重计数
    For j = 4 To UBound(err) '循环行
        For m = 2 To UBound(err, 2) '循环列
         If err(j, m) <> "" Then
                 str = err(j, m) & "##" & err(j, 1)
                If d.exists(str) Then
                    d.Item(str) = d.Item(str) + 1
                    d1.Item(str) = d1.Item(str) + frr(j, m)
                    d2.Item(str) = d2.Item(str) & "/" & err(2, m)
                Else
                    d.Add str, 1
                    d1.Add str, frr(j, m)
                    d2.Add str, err(2, m)
                 End If
            End If
        Next
    Next
    crr = d.keys '将教师及学科装入数组crr方便分列到arr1
    ReDim arr1(LBound(crr) To UBound(crr), 1 To 3)
    For i = LBound(crr) To UBound(crr)
        arr1(i, 1) = i + 1 '增加序号
        arr1(i, 2) = Split(crr(i), "##")(0) '教师姓名
        arr1(i, 3) = Split(crr(i), "##")(1) '任教学科
    Next
    With Sheets("统计")
    .Cells.Clear '清空统计表
    .Range("a1").Resize(1, 6) = [{"序号", "教师", "学科", "班级数", "课时数","对应班级"}]
    .Range("a2").Resize(d.Count, 3) = arr1 '填入序号,教师,学科
    .Range("d2").Resize(d.Count) = Application.Transpose(d.items) '填入班级数
    .Range("e2").Resize(d.Count) = Application.Transpose(d1.items) '填入课时数
    .Range("f:f").NumberFormatLocal = "@" '设置文本格式
    .Range("f2").Resize(d.Count) = Application.Transpose(d2.items) '填入对应班级
    End With
    
    
End Sub