观看视频了解更多

一、问题的提出

学校教务处在编排课程表时，第一步要根据学校对教师工作任务的分配，制作班级任课表（如下图），班级任课表可清晰地呈现各班级、各学科的教师任课情况。

第二步要制作教师任课表，要在《班级任课表》基础上，对全校每位教师担任哪一个班级的哪一门学科进行汇总，既方便教师查询自己的任课情况，也是我们后续编排教师课程表的前提。

当学校教师数量较多时，手动输入制作教师任课表真的是一件费时费力的苦差，我真的不想这么过了，这苦这累成了倒逼我寻找简捷方法的动力。我们研究上述《班级任课表》和《教师任课表》，会发现二者之间是有内在联系的，只不过是信息的呈现方式不一样，完全可以利用《班级任课表》直接转化为《教师任课表》，经过一段时间的探索，我用VBA完成了这个转化，今天，我来分享自己的探索成果，希望能给被同样问题困扰的教务同行有所帮助与启发。

二、问题解决

1、右击《班级任课表》工作表标签，在弹出的快捷菜单中选择"查看代码"命令，在打开的VBA窗口中输入以下代码：

Sub 获取教师唯一姓名()

On Error Resume Next

Application.ScreenUpdating = False

Dim R As Integer, C As Integer, sht As Worksheet

Dim s As String, JsName, JsOnly, h, firstAddress

Dim k As Integer, i As Integer, j As Integer, n As String

Dim strRenKe As String, Rng As Range, bj As String, rk As String

Set mydic = CreateObject("Scripting.Dictionary")

Set sht = Worksheets("班级任课表")

C = sht.Range("A2").End(xlToRight).Column '获取最右一列列号

R = sht.Range("A2").End(xlDown).Row '获取最后一行行号

s = "B4:" & GCB(Val(C)) & R

'获取教师任课数据区域，GCB为自定义函数，用于从列号获取列标

JsName = sht.Range(s).Value '将教师姓名存储在二维数组JsName(k,i)中

s = "B3:" & GCB(Val(C)) & R '查找时向左扩展一行，以便能从B4开始查找

Set Rng = sht.Range(s)

For k = 1 To R - 3 '从B4开始，故数组第一维从1至R－3，减去前3行

For i = 1 To C - 1 '从B4开始，故数组第二维从1至C－1，减去A列

n = Trim(JsName(k, i)) '获取教师姓名，用于查找任课情况

strRenKe = "" '清空教师任课情况，用于循环查找下一位教师任课

If Not mydic.Exists(n) And n <> "" Then '当教师姓名不为空，关键字不存在时

With Rng '对教师区域进行查找

bj = "": rk = ""

Set h = .Find(n)

If Not h Is Nothing Then

firstAddress = h.Address

Do

If Left(bj, 1) = Left(sht.Cells(3, h.Column), 1) And rk = sht.Cells(h.Row, "A") Then

bj = sht.Cells(3, h.Column) '获取班级名称

rk = sht.Cells(h.Row, "A") '获取学科名称

strRenKe = Left(strRenKe, Len(strRenKe) - Len(rk)) & Right(bj, 1) & rk

ElseIf rk = sht.Cells(h.Row, "A") Then

bj = sht.Cells(3, h.Column) '获取班级名称

rk = sht.Cells(h.Row, "A") '获取学科名称

strRenKe = Left(strRenKe, Len(strRenKe) - Len(rk)) & bj & rk

Else

bj = sht.Cells(3, h.Column) '获取班级名称

rk = sht.Cells(h.Row, "A") '获取学科名称

strRenKe = strRenKe & bj & rk

End If

Set h = .FindNext(h)

Loop Until h Is Nothing Or h.Address = firstAddress

End If

End With

mydic.Add n, strRenKe

End If

Next i

Next k

Set sht = Worksheets("教师任课表")

JsOnly = mydic.Keys '获取教师姓名，转置在A列

sht.Range("A2:A" & mydic.Count + 1) = WorksheetFunction.Transpose(JsOnly)

JsOnly = mydic.Items '获取教师任课，转置在B列

sht.Range("B2:B" & mydic.Count + 1) = WorksheetFunction.Transpose(JsOnly)

Set Rng = Nothing: Set sht = Nothing

Application.ScreenUpdating = True

End Sub

2、代码注释

⑴s = "B4:" & GCB(Val(C)) & R

C是获取最右一列列号，这与学校班级数量多少有关，这个C获取的是字符型数字，所以用Val函数才能将字符型数字C，转换成数值型数字。然后利用自定义函数GCB从列号获取列标字母，如37就转换为AK，从而获取教师任课数据区域。

⑵自定义函数GCB代码（这段代码最好放在模块中）

Public Function GCB(Num As Integer) As String

'快速将列标数字转化为列标（如2转化为B，16384转化为XFD等）

Application.ScreenUpdating = False

On Error Resume Next

If Num > 16384 Or Num < 1 Then Exit Function

Dim y As Integer, s As String

s = ""

Do

y = Num Mod 26

If y = 0 Then

s = Chr(64 + 26) & s

Num = Num \ 26 - 1

Else

s = Chr(64 + y) & s

Num = Num \ 26

End If

Loop Until Num = 0

GCB = Trim(s)

Application.ScreenUpdating = True

End Function

⑶Set mydic = CreateObject("Scripting.Dictionary")

用于创建一个字典mydic，利用字典关键字的唯一性，从班级任课表中有重复的教师姓名中获取每位教师姓名的唯一值。

⑷Set h = .Find(n)与Set h = .FindNext(h)

n储存的是一位教师的姓名，根据教师的姓名获取他的所有任课，Find是查找，FindNext是查找下一个直到查找完毕。

⑸Do……Loop循环中的多个If语句，用于处理教师任课中的冗余字符，譬如同一年级名称、同一学科名称只显示一个，这样数据更简洁直观。

⑹WorksheetFunction.Transpose(JsOnly)

JsOnly是储存教师姓名或教师任课的一维数组，对应于工作表中一行数据，要把一行数据转置为一列数据，使用工作表函数之转置函数WorksheetFunction.Transpose。