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

擦声而过

刚接触教务工作，制作总课表后通过复制出教师课表非常繁琐，
想通过VBA解决，无奈水平有限，请大神指点，不知道思路对否。
想通过总表“表1”，利用“表2”，生成如图各位老师的课程表，工作表的名称也以老师命名。万分感谢！！

表1

表1

表2

表2

教师课程表.zip (37.41 KB, 下载次数: 149)

2016-12-14 14:19 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-14 15:30

这是个练习字典的好例子。

跳转到最佳答案楼层

grf1973

这是个练习字典的好例子。

擦声而过

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

{:1112:}大神，我得逐行消化消化~~万分感谢！！

上清宫主

凑热闹，没写判断、删除表的代码
Sub test()
Dim d
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)
        ss1 = ar(1, i1) & "|" & ar(i2, i1)
        ss2 = d(ss1)
Next i2, i1
ss2 = d("1|语")
ar = Sheets("表2").[a2:l4].Value
For i1 = 1 To UBound(ar)
     Set s = Sheets.Add
     s.Name = ar(i1, 1)
     Sheets("表3").Cells.Copy s.[a1]
     s.[g2] = 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), "、")
                s.Cells(Right(stmp, 1) * 1 + 4, Left(stmp, 1) * 1 + 2) = "七（" & ar(i1, i2) & "）"
            Next
         End If
     Next
Next
End Sub

today0427

不用字典我也来一个 新建文件夹.rar (32.37 KB, 下载次数: 70)

2016-12-14 19:32 上传

点击文件名下载附件

1. Sub today() '总课表生成教师课表
   
2.     Dim i&, j%, iz&, jz%, arrz, arrj, brr(1 To 9, 1 To 5)
   
3.     arrz = Sheets("表1").Range("d5:ba13")
   
4.     arrj = Sheets("表2").Range("a1").CurrentRegion
   
5.     For i = 2 To UBound(arrj)
   
6.         For j = 3 To UBound(arrj, 2)
   
7.             If arrj(i, j) = "" Then Exit For
   
8.             For jz = arrj(i, j) To UBound(arrz, 2) Step 10
   
9.                 For iz = 1 To UBound(arrz)
   
10.                     If arrz(iz, jz) = arrj(i, 2) Then brr(iz, Int((jz - 1) / 10 + 1)) = "七（" & arrj(i, j) & "）"
    
11.                 Next
    
12.             Next
    
13.             
    
14.         Next
    
15.         Application.DisplayAlerts = False
    
16.         On Error Resume Next
    
17.             If Not IsError(Sheets(arrj(i, 1)).Select) Then Sheets(arrj(i, 1)).Delete
    
18.             Sheets("表3").Copy After:=Sheets(Sheets.Count)
    
19.             With ActiveSheet
    
20.                 .Name = arrj(i, 1)
    
21.                 .[g2] = arrj(i, 1)
    
22.                 .[c5].Resize(9, 5) = brr
    
23.             End With
    
24.         On Error GoTo 0
    
25.         Application.DisplayAlerts = True
    
26.         Erase brr
    
27.     Next
    
28. End Sub
    

复制代码

today0427

不过我诚恳地建议楼主，最好不要在一个工作簿中生成这种多表的课程表，复制建表浪费时间不说，往少里说点，假设你们学校有50名老师，想象一下选择其中一位老师的课表查看，那种感觉一言难尽。倒不如只建立一张教师个人课表，用字典生成教师名单作为课表的有效性下拉菜单，然后选择教师生成课表，打印的时候只需要用程序按照下拉菜单的名单一个一个生成打印出来就行了。或者用inputbox输入教师姓名查看打印课表都行。个人经验，仅供参考。

上清宫主

确实如楼上所说，一个年级就10个班，初中三个年级，这大致可估计出教师人数，一个教师一张表，在实际工作中这样做够他受的。以前遇到过一个中层，他算老师的课时津贴也是一人一表张，结果用了两月就再也不这么用了
可以做成下拉的，或者就做到几张表（分年级或分学科来填）甚至一张表中，查看也很方便

擦声而过

上清宫主 发表于 2016-12-15 07:32
确实如楼上所说，一个年级就10个班，初中三个年级，这大致可估计出教师人数，一个教师一张表，在实际工作中 ...

非常感谢楼上两位的帮助!请问下拉菜单式可不可以整体都打印出来呢，因为在学期初要把每个老师的课程表发到手上。

today0427

可以啊，程序整个把教师姓名过一遍，生成一张表就打印一张表，按一下按钮就全部打完

today0427

类似于这种，我以前还不太会的时候乱写了一个，你可以参考下

1. Sub 成绩登记册选择班级全部打印()
   
2.     Dim x As Integer, arr
   
3.             arr =  Sheets("家长会签到表").Range("l3:l38") '这是所有班级的班级名，从家长会签到表的单元格导入的，你也可以直接放进数组中
   
4.          With Sheets("登记")
   
5.                 For x = 1 To 36
   
6.                     .Range("b2") = arr(x, 1)
   
7.                     Sheets(Array("封面", "汇总", "登记")).Select
   
8.                      ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
   
9.                 Next x
   
10.             End With
    
11.     End Sub
    

复制代码