如何从任课表中提取出教师的任课班级

lfy123456

我需要一个从教师的任课表中提取出教师的任课情况，包含任教年级，任教科目，任教班级，任教节数，请各位大神帮助一下看看能否提出

3190496160

Sub test()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("任课表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For j = 5 To UBound(ar, 2)
    dc(ar(2, j)) = ""
Next j
ReDim br(1 To 200, 1 To 8)
For i = 4 To UBound(ar)
    For j = 5 To UBound(ar, 2)
        If ar(i, j) <> "" Then
            If Not dc.exists(ar(i, j)) Then
                If Not IsNumeric(ar(i, j)) Then
                    t = d(ar(i, j))
                    If t = "" Then
                        k = k + 1
                        d(ar(i, j)) = k
                        t = k
                        br(k, 1) = k
                        br(k, 2) = ar(i, j)
                        br(k, 3) = ar(2, j)
                        br(k, 4) = ar(i, 1)
                    End If
                    If br(t, 5) = "" Then
                        br(t, 5) = ar(i, 2)
                    Else
                        br(t, 5) = br(t, 5) & "," & ar(i, 2)
                    End If
                    br(t, 8) = br(t, 8) + 1
                End If
            End If
        End If
    Next j
Next i
For i = 1 To k
    dc.RemoveAll
    rr = Split(br(i, 5), ",")
    br(i, 5) = ""
    For s = 0 To UBound(rr)
        zd = rr(s)
        If Not dc.exists(zd) Then
            If br(i, 5) = "" Then
                br(i, 5) = zd
            Else
                br(i, 5) = br(i, 5) & "、" & zd
            End If
            dc(zd) = dc(zd) + 1
        End If
    Next s
    br(i, 6) = dc.Count
    br(i, 7) = br(i, 8) / dc.Count
Next i
With Sheets("Sheet2")
    .UsedRange.Offset(2).Borders.LineStyle = 0
    .UsedRange.Offset(2) = Empty
    .[a3].Resize(k, UBound(br, 2)) = br
    .[a3].Resize(k, UBound(br, 2)).Borders.LineStyle = 1
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

教师任课情况.rar (30.04 KB, 下载次数: 4)

2024-8-24 09:29 上传

点击文件名下载附件

梅花香自苦寒

yangfan634  加我好友  

清风竹-

请看附件。

edwin11891

公式较多，直接上结果。
sheet2页有按照课程顺序排序，还可以使用SORT（SORTBY）函数指定按照任意列排序。

edwin11891

修订公式，全部公式修改为自动溢出，无需下拉，并在第一页直接已按照科目排序。