[已解决]总课表生成教师和班级课表，感觉比排课软件还给力

擦声而过

today0427 发表于 2016-12-15 08:09
类似于这种，我以前还不太会的时候乱写了一个，你可以参考下

太感谢了，看来老师同行还不少啊！我这还是一个年级生成的课表，全校百十位牵扯到各个年级，还没想到怎么统一能生成教师课表！想想都复杂{:2312:}
现在这样我已经很满足了{:1712:}

上清宫主

语数外跨年级的少，音体美等基本都要跨年级。
就把你的表1、表2完善好，把前面的代码略改造一下，就可以把整个学校的所有老师（不管你是纯初中，还是完中、小初高在一起）的课表全生成到一张sheet中去，要打印、要查询都方便

前面给你提供的代码基本思路是：用“班|课”做为字典的KEY，用星期-节做item，添加进字典，在老师表中，只需查“班|课”的对应星期-节填进表就可以了。
多年级时只把KEY前增加个年级信息，多学段时再加上学段信息，以此类推，很简单的

擦声而过

grf1973 发表于 2016-12-14 15:30
这是个练习字典的好例子。

万分感谢！！尤其是可以删除，这样的话如果中途有个别调课的老师也可以重新生成！！太方便了！请问要把生成班级课表也加到里边就更完美了，不过一生成就把样表2就冲掉了，请劳烦指导一下!!


教师班级课程表（自动生成）.zip (36.75 KB, 下载次数: 79)

2016-12-15 09:10 上传

点击文件名下载附件

擦声而过

上清宫主 发表于 2016-12-15 08:39
语数外跨年级的少，音体美等基本都要跨年级。
就把你的表1、表2完善好，把前面的代码略改造一下，就可以把 ...

{:2712:}对于大神级别的很简单，小菜鸟要好好学习啦！！万分感谢！！

grf1973

请看附件。

上清宫主

几个都写了，所有老师的课表都生成在教师课表中，所有班的课表都在班级课表中
Sub 生成教师课表()
Application.DisplayAlerts = 0
Dim sht, d, ar()
On Error Resume Next
  Set sht = Sheets("教师课表")
  If Err = Empty Then sht.Delete
  Set sht = Sheets.Add(, Sheets(Sheets.Count))
  sht.Name = "教师课表"
On Error GoTo 0
Set d = CreateObject("scripting.dictionary")
ar = Sheets("表1").[C4:ba12].Value
For i1% = 2 To UBound(ar, 2)
    If ar(1, i1) = 1 Then xq = xq% + 1
    For i2% = 2 To UBound(ar)
        d(ar(1, i1) & "|" & ar(i2, i1)) = d(ar(1, i1) & "|" & ar(i2, i1)) & "、" & xq & "-" & ar(i2, 1)
Next i2, i1
ar = Sheets("表2").[a2:l10].Value
For i1 = 1 To UBound(ar)
     With sht
     Sheets("样表").Range("a1:g13").Copy .Cells(r% + 1, 1)
     .Cells(r% + 2, 7) = ar(i1, 1)
     For i2 = 3 To UBound(ar, 2)
         If ar(i1, i2) <> "" Then
            For Each stmp In Split(Mid(d(ar(i1, i2) & "|" & ar(i1, 2)), 2), "、")
                .Cells(Right(stmp, 1) * 1 + 4 + r, Left(stmp, 1) * 1 + 2) = "七（" & ar(i1, i2) & "）"
            Next
         End If
     Next
     r = r + 15
     End With
Next
Application.DisplayAlerts = 1
End Sub
Sub 删除教师课表()
Application.DisplayAlerts = 0
Dim sht
On Error Resume Next
  Set sht = Sheets("教师课表")
  If Err = Empty Then sht.Delete
On Error GoTo 0
Application.DisplayAlerts = 1
End Sub

Sub 生成班级课表()
Application.DisplayAlerts = 0
Dim sht
On Error Resume Next
  Set sht = Sheets("班级课表")
  If Err = Empty Then sht.Delete
  Set sht = Sheets.Add(, Sheets(Sheets.Count))
  sht.Name = "班级课表"
On Error GoTo 0
For i1% = 1 To 10
     With sht
     Sheets("样表2").Range("a1:g14").Copy .Cells(r% + 1, 1)
     .Cells(r% + 2, 6) = "（" & Sheets("表1").Cells(4, i1 + 3) & "）"
     For i2% = 1 To 5
         .Cells(r% + 5, i2 + 2).Resize(5) = Sheets("表1").Cells(5, i1 - 7 + i2 * 10).Resize(5).Value
         .Cells(r% + 11, i2 + 2).Resize(4) = Sheets("表1").Cells(10, i1 - 7 + i2 * 10).Resize(4).Value
     Next
     r = r + 16
     End With
Next
Application.DisplayAlerts = 1
End Sub
Sub 删除班级课表()
Application.DisplayAlerts = 0
Dim sht
On Error Resume Next
  Set sht = Sheets("班级课表")
  If Err = Empty Then sht.Delete
On Error GoTo 0
Application.DisplayAlerts = 1
End Sub

擦声而过

{:3512:}~~万分感谢楼上二位！！
感觉比排课软件更方便！！！

today0427

两位老师太棒了！

轻松

比排课软件更方便

hhzjxss

还有几名课程没有老师教呀！