根据总课程表分别生成班级课程表和教师课程表

yynrzwh

不同班级是否视为连续？

3190496160

Sub 教师课表()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim br()
With Sheets("总课表")
    r = .Cells(Rows.Count, 9).End(xlUp).Row
    If r < 7 Then MsgBox "总课表为空！": End
    ar = .Range("i4:cu" & r)
End With
With Sheets("教师名单")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "教师名单表为空！": End
    cr = .Range("a1:a" & rs)
End With
For j = 3 To UBound(ar, 2)
    If ar(2, j) = "" Then ar(2, j) = ar(2, j - 1)
Next j
rr = Array(1, 3, 4, 6, 7, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19)
With Sheets("教师课表")
    .Activate
   rs = .Cells(Rows.Count, 9).End(xlUp).Row
   If rs > 21 Then .Rows("22:" & rs).Delete
    k = 1
    For s = 2 To UBound(cr)
        Erase br
        ReDim br(1 To 21, 1 To 6)
        y = 0
        If cr(s, 1) <> "" Then
            xm = cr(s, 1)
             For j = 2 To UBound(ar, 2) Step 15
                y = y + 1
                For ss = j To j + 14
                    If ss <= UBound(ar, 2) Then
                        For i = 4 To UBound(ar)
                            zd = ar(i, ss)
                            If InStr(zd, xm) > 0 Then
                                zf = ar(2, ss)
                                kc = Split(ar(i, ss), Chr(10))(0) & Chr(10) & ar(i, 1)
                                If InStr(zf, "早") > 0 Then
                                    br(1, y) = kc
                                ElseIf InStr(zf, "上") > 0 Then
                                    If ar(3, ss) = 1 Or ar(3, ss) = 2 Then
                                        br(ar(3, ss) + 2, y) = kc
                                    Else
                                        br(ar(3, ss) + 3, y) = kc
                                    End If
                                ElseIf InStr(zf, "自") > 0 And InStr(zf, "晚") = 0 Then
                                    br(ar(3, ss) + 8, y) = kc
                                ElseIf InStr(zf, "下") > 0 Then
                                    br(ar(3, ss) + 10, y) = kc
                                ElseIf InStr(zf, "后") > 0 Then
                                    br(ar(3, ss) + 12, y) = kc
                                ElseIf InStr(zf, "晚") > 0 Then
                                    br(ar(3, ss) + 15, y) = kc
                                End If
                            End If
                        Next i
                    End If
                Next ss
            Next j
            If k > 1 Then
                .Rows("1:21").Copy .Cells(k, 1)
            End If
            For ss = 0 To UBound(rr)
                x = rr(ss) + k + 1
                .Cells(x, 3).Resize(1, 6) = Empty
            Next ss
            .Cells(k, 1) = cr(s, 1) & "  教  师   课   程   表"
            .Cells(k + 2, 3).Resize(UBound(br), UBound(br, 2)) = br
            k = k + 21
        End If
    Next s
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助：如何用公式或VBA将Sheet1总课程表生成教师课程表和班级课程表.rar (95.57 KB, 下载次数: 18)

2024-8-7 09:29 上传

点击文件名下载附件

3190496160

增加了生成教师课表功能，结果为认真核对，仅供参考

cai2532

这个留下脚印学习了。