用vba生成任课教师课程表

cyq4896 · 发表于 2024-9-30 10:11

本帖最后由 cyq4896 于 2024-9-30 10:56 编辑

请老师们用vba根据总课程表和教师任课表，用模板生成任课教师课程表。

wengjl · 发表于 2024-9-30 11:27

一个细节注意不到，VBA再正确也实现不了！！！
细节是：
总课程表与教师任课表，二个表上的班级名称是不相等的，因为总课程表上的班级名称中间多一个人工换行符的！

3190496160 · 发表于 2024-9-30 11:40

Sub 教师课表()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("教师任课表")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r < 2 Or y < 2 Then MsgBox "教师任课表为空！": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For i = 2 To UBound(ar)
For j = 2 To UBound(ar, 2)
      If ar(i, j) <> "" Then
         If Not d.exists(ar(i, j)) Then
            d(ar(i, j)) = ar(i, 1) & "|" & ar(1, j)
         Else
            d(ar(i, j)) = d(ar(i, j)) & "," & ar(i, 1) & "|" & ar(1, j)
         End If
      End If
Next j
Next i
With Sheets("总课程表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
ys = .Cells(3, Columns.Count).End(xlToLeft).Column
If rs < 4 Or ys < 3 Then MsgBox "总课程表为空！": End
br = .Range(.Cells(1, 1), .Cells(rs, ys))
End With
m = 1
With Sheets("任课教师课程表")
ws = .Cells(Rows.Count, 1).End(xlUp).Row
If ws > 10 Then .Rows("11:" & ws).Delete
For Each k In d.keys
      zf = d(k)
      ReDim arr(1 To 8, 1 To 6)
      arr(1, 1) = 1
      arr(2, 1) = 2
      arr(4, 1) = 3
      arr(5, 1) = 4
      arr(7, 1) = 5
      arr(8, 1) = 6
      arr(3, 1) = "课间操"
      arr(6, 1) = "午间"
      y = 1
      For j = 2 To UBound(br, 2) Step 12
         y = y + 1
         For s = j To j + 11
            For i = 4 To UBound(br)
                  If i < 6 Then
                     xh = br(i, 1)
                  ElseIf i >= 6 And i <= 7 Then
                     xh = br(i, 1) + 1
                  ElseIf i >= 8 Then
                     xh = br(i, 1) + 2
                  End If
                  If br(i, s) <> "" Then
                     zd = Replace(br(3, j), Chr(10), "") & "|" & br(i, s)
                     If InStr(zf, zd) > 0 Then
                        arr(xh, y) = br(i, s) & Chr(10) & Replace(br(3, j), Chr(10), "")
                     End If
                  End If
            Next i
         Next s
      Next j
      If m = 1 Then
         .Cells(m, 1) = k & "课程表"
         .Cells(m + 2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
      Else
         .Rows("1:10").Copy .Cells(m, 1)
         .Range(.Cells(m + 2, 1), .Cells(m + 9, 6)) = Empty
         .Cells(m, 1) = k & "课程表"
         .Cells(m + 2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
      End If
      m = m + 10
Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub