本文于2023年8月16日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
根据课程总表生成班级课程表
根据课程总表生成教师排课表
大家好，我是冷水泡茶，昨天的文章【Excel VBA 批量生成凭证抽查底稿/审计小助手】收到一个朋友的大赞赏，在此表示感谢！当然，他还是有一点小需求的，希望我能帮他做一个排课表，那我自然是一口应承（好在不是很复杂，要不就尴尬了），在征得他同意后，我把这个案例分享给大家：
他的明细表“课程总表”是这样的，有30个班级：
他要做成分班级的课程表、教师课程表：
班级课程表
教师课程表
他的需求是：一键生成所有班级课程表、教师课程表。
我经过一番研究，有了思路，最终完成交差：
基本思路
1、总的来说，这是一个数据转置的问题。
2、通过循环1~5（周一到周五），1~8（8节课程），取得单元格数据，填到目标表当中。
3、可以生成所有课程表、直接打印课程表，跟我们昨天分享的文章【Excel VBA 批量生成凭证抽查底稿/审计小助手】有很多相似的地方，甚至有些代码可以直接拿来使用。
程序代码
1、ArrangeCourse，安排课程：
Public ProcessType As StringPublic wsOrig As Worksheet '准备装课程总表Sub ArrangeCourse() Dim wsClass As Worksheet '准备装班级模板 Dim wsTeacher As Worksheet '准备装教师模板 Dim ClassName As String '班级课程表名称 Dim ClassWithTeacher As String '班级课程表（带教师）名称 Dim lastRow As Long '课程总表最大使用的行。 Dim rngCourse As Range '课程总表中，课程区域 Dim rngTeacher As Range '课程总表中，教师区域 Set wsOrig = ThisWorkbook.Sheets("课程总表") lastRow = wsOrig.UsedRange.Rows.Count Set wsClass = ThisWorkbook.Sheets("班级课程表（模板）") Set wsTeacher = ThisWorkbook.Sheets("带教师信息（模版）") '循环课程总表,从第5行开始 For i = 5 To lastRow If wsOrig.Cells(i, 1) = "" Then Exit For '如果第一列是空单元格，说明后面没有排课数据了，退出循环，用exit sub应该也可以，就看循环结束后面有没有其他代码。 If i Mod 2 Then '奇数行是课程，下一行是教师，把它们赋值给相应的Range对象 Set rngCourse = wsOrig.Range("B" & i & ":AO" & i) Set rngTeacher = wsOrig.Range("B" & i + 1 & ":AO" & i + 1) With wsClass '把数据填入"班级课程表（模板）" .Range("K2") = wsOrig.Cells(i, 1) '表头班级名称 ClassName = .Range("K2") '班级表名 m = 0 '由于模板中，有空白列，课间休息什么的，用m来修正列标 For j = 1 To 5 '周一到周五 For k = 1 To 8 '8节课 If k = 2 Or k = 4 Or k = 6 Then m = m + 1 End If '下面这句是核心，实际也是一个数学问题，如果看不明白，可以试着把k,j以具体的数字带进去，看看cells（r,c）到底是什么结果。 .Cells(j + 5, k + 1 + m) _ = rngCourse.Cells(1, k + (j - 1) * 8) Next m = 0 Next End With With wsTeacher '把数据填入"带教师信息（模版）"，跟"班级课程表（模板）"差不多。 .Range("I2") = wsOrig.Cells(i, 1) ClassWithTeacher = ClassName & "（教师）" For j = 1 To 5 For k = 1 To 8 .Cells(j * 2 - 1 + 3, k + 1) _ = rngCourse.Cells(1, k + (j - 1) * 8) .Cells(j * 2 + 3, k + 1) _ = rngTeacher.Cells(1, k + (j - 1) * 8) Next Next End With '根据不同的命令按钮，执行生成工作表或打印工作表的过程。 If ProcessType = "生成" Then Call CopyWorksheet(wsClass, ClassName) ThisWorkbook.Sheets(ClassName).Tab.Color = RGB(195, 253, 164) Call CopyWorksheet(wsTeacher, ClassWithTeacher) ThisWorkbook.Sheets(ClassWithTeacher).Tab.Color = RGB(74, 219, 222) ElseIf ProcessType = "打印" Then Call PrintSheet(wsClass) Call PrintSheet(wsTeacher) End If 'Stop End If NextEnd Sub
代码解析：
（1）定义PublicProcessType字符串变量，用来记录是生成排课表还是打印排课表。
（2）定义Public wsOrig工作表对象，为了在“课程总表”中执行生成、打印过程后，激活返回“课程总表”，定义这个变量方便一点。
（3）定义过程变量，具体解释看代码块吧。
（4）循环课程总表，把课程行赋值给Range对象rngCourse，把教师行赋值给range对象rngTeacher。再通过两层循环，把Range对象中的数据写入到两个课程表模板。
（5）根据不同的命令按钮，执行生成工作表或打印工作表的过程。生成工作表的时候，把班级课表标签、教师课表标签设置成不同的颜色。
2、其他过程：CopyWorksheet、PrintSheet、wContinue：
Sub CopyWorksheet(sourceWorksheet As Worksheet, wsName As String) Dim targetWorksheet As Worksheet '检查是否存在同名的目标工作表，如果存在则删除 On Error Resume Next Set targetWorksheet = ThisWorkbook.Worksheets(wsName) On Error GoTo 0 If Not targetWorksheet Is Nothing Then Application.DisplayAlerts = False targetWorksheet.Delete Application.DisplayAlerts = True End If '复制源工作表到同一个工作簿 sourceWorksheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '获取新复制的工作表的引用 Set targetWorksheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '重命名新复制的工作表 targetWorksheet.Name = wsNameEnd SubSub PrintSheet(ws As Worksheet) ws.PrintOut Copies:=1 Application.Wait Now + TimeSerial(0, 0, 0.5)End SubFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Config = vbYesNo + vbDefaultButton2 + vbQuestion Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) & "否(N)返回！", Config, "请确认操作！") wContinue = Ans = vbYesEnd Function
代码解析：
（1）CopyWorksheet，复制工作表，跟昨天文件中的代码类似，由于这里需要复制两个工作表，所以设置了过程参数：源工作表，新工作表名，把“源工作表”复制成以“新工作表名”命名的工作表。
（2）PrintSheet，打印工作表，同样设置了参数：工作表，打印指定工作表。
（3）wContinue，确认是否继续执行的函数，这是我们的老朋友了，在很多场合都会用到它，把以前的文件中的代码直接复制过来就行。（删除了一条无用的定义变量的代码。）
3、“课程总表”上的命令按钮：CmdCreateSheets、CmdPrintSheets：
Private Sub CmdCreateSheets_Click() If Not wContinue("即将删除并重新生成排课表！") Then Exit Sub Application.ScreenUpdating = False ProcessType = "生成" Call ArrangeCourse Application.ScreenUpdating = True wsOrig.Activate MsgBox "排课表制作完成！" End SubPrivate Sub CmdPrintSheets_Click() If Not wContinue("即将打印所有排课表！") Then Exit Sub If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub End If Application.ScreenUpdating = False ProcessType = "打印" Call ArrangeCourse Application.ScreenUpdating = True wsOrig.Activate MsgBox "排课表打印完成！" End Sub
代码解析：
（1）在执行过程前，有一个确认继续执行的判断，防止误点按钮，给一个反悔的机会。
（2）点击不同的命令按钮，给ProcessType赋不同的值，在ArrangeCourse过程中据以执行不同的操作。
（3）接着调用ArrangeCouse过程。
（4）执行完毕，返回“课程总表”。
总结
1、代码的力量还是非常惊人的，据提供案例的这位朋友所言，如果硬粘贴的话，得要半天功夫，如果总表有调整的话，还得再花费半天，很是头疼。所以说，了解一点VBA代码，一定会提高办公效率。
2、我们平时可以积累一些过程、函数代码块，在以后需要用到的时候可以拿来使用，最多稍作修改，不必要重新去写了。
3、另外，昨天的文件有点小BUG，批量打印过程有点调整，把下面的代码从过程Sub PrintSheet()移到窗体中的
Private Sub CmdPrint_Click()中，要不每打印一张就要确认一下（Sorry）：
If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub End If
更新后的代码（这样一来PrintSheet过程就可以直接合并到下面的CmdPrint_Click中去了）：
Sub PrintSheet() ThisWorkbook.Sheets("凭证抽查（模板）").PrintOut Copies:=1End SubPrivate Sub CmdPrint_Click() If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub End If '循环ListBox For i = 0 To Me.LstAccName.ListCount - 1 If Me.LstAccName.Selected(i) Then accName = Me.LstAccName.List(i) Call SelectData(accName) Call PrintSheet End If Next MsgBox "抽查表打印完成！" Unload MeEnd Sub
---End---
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！