如何提取班级及任课教师课程表
以前都是要麻烦别人，但现在自己也可以解决了。
首先要保证一点：教师姓名必须要保持一致，写的过程就发现了有些老师的姓名前后不一致导致最终结果里面没有他们的课程表（为空）。
需要准备的文件（所有表格均存放在同一工作簿中）：
①任课教师表（jsb)如下图所示：(特别注意，必须按班级顺序排序！！）
②课程表（kcb)如下图所示：（首行必须做成如图所示样式，因为需要在此表中填写任课教师的姓名。）
③教师课程表（jskcb)如下图所示；（用于存储最终结果，此表最终为空表。）
④教师代码表（jsdmb)如下图所示：
准备好以下四张表后，就可以按如下源程序进行提取教师课程表：
Sub 取消合并单元格并保留内容()
Dim strmer As String '用于存储需要取消合并单元格的内容
Dim intcot As Integer '用于存储被合并单元格的个数
Dim i As Integer, j As Integer '用于循环计数
Dim totalR As Integer, totalC As Integer '用于统计行数
Dim myrange As Range
Worksheets(1).Activate
totalR = Range("B65536").End(xlUp).Row
totalC = Range("IV2").End(xlToLeft).Column '由于最后一列首行也为合并单元格,故取第256列的第2行计算列号.
Debug.Print totalR, totalC
For j = 1 To totalC
For i = 2 To totalR
Set myrange = Range(Cells(i, j), Cells(i, j))
strmer = myrange.Value
intcot = myrange.MergeArea.Count
myrange.UnMerge
Range(Cells(i, j), Cells(i + intcot - 1, j)).Value = strmer
i = i + intcot - 1
Next i
Next j
Set myrange = Nothing
'去掉电话号码行,因为电话号码所在列的首行为空(虽然已经合并,但并不影响删除!!),所以利用这点检测到为空则将整列删除.
For j = totalC To 1 Step -1
If Range(Cells(1, j), Cells(1, j)).Value = "" Then
Range(Cells(1, j), Cells(1, j)).EntireColumn.Delete
End If
Next j
End Sub
Sub 教师课程表()
Dim jsA(17, 25), jsB(116) As String
Dim kmA(17, 25) As String
Dim km As String
Dim js(116) As String
Dim bj As String
Dim mycell, mycell2 As Range
Dim jc1 As Integer
Dim jc2 As String
Dim i, h, l, t As Integer
'读取"jsb"中的每位教师的姓名及任教学科
Worksheets("jsb").Activate
For h = 1 To 14
For l = 1 To 25
jsA(h, l) = Cells(h + 1, l + 1).Value
kmA(h, l) = Cells(h + 1, 1).Value
Next l
Next h
'根据读取的jsA，kmA数据，填充"kcb"的教师姓名
Worksheets("kcb").Activate
For l = 1 To 25
For jc1 = 2 To 36
km = Cells(jc1, 2 * l).Value
For h = 1 To 14
If km = kmA(h, l) Then
Cells(jc1, 2 * l + 1).Value = jsA(h, l)
End If
Next h
Next jc1
Next l
End Sub
Sub 统计重复()
Dim totalR As Integer, totalC As Integer, i As Integer, j As Integer
Worksheets("kcb").Activate
totalR = Range("A65536").End(xlUp).Row
totalC = Range("IV1").End(xlToLeft).Column
For i = 1 To totalR
For j = 1 To totalC
If Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, totalC)), Cells(i, 3 + (j - 1) * 2)) >= 2 Then
Range(Cells(i, 3 + (j - 1) * 2), Cells(i, 3 + (j - 1) * 2)).Font.ColorIndex = 3
Range(Cells(i, 3 + (j - 1) * 2), Cells(i, 3 + (j - 1) * 2)).Interior.ColorIndex = 15
End If
Next j
Next i
End Sub
Sub 老师课程表表格模式设计()
Dim js(116) As String
Dim mycell As Range
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
For i = 1 To 116
js(i) = Cells(i + 1, 2).Value
Next i
'end
'设计教师课表的表头部分
Worksheets("jskcb").Activate
For i = 1 To 116
Range(Cells(12 * i - 11, 1), Cells(12 * i - 10, 6)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Value = js(i) + " 老师课程表"
Selection.Font.Size = 18
Next i
'end
'设计教师课表的行头及列头标题
For i = 1 To 116
Range("A3:A10").Copy Destination:=Cells(12 * i - 9, 1)
Range("A3:F3").Copy Destination:=Cells(12 * i - 9, 1)
Next i
'end
For i = 1 To 116
Cells(12 * i - 9, 1).Value = js(i)
Next i
End Sub
Sub 教师课表()
Dim jsA(17, 25), jsB(116) As String
Dim kmA(17, 25) As String
Dim km As String
Dim js(116) As String
Dim bj As String
Dim mycell, mycell2 As Range
Dim jc1 As Integer
Dim jc2 As String
Dim i, h, l, t As Integer
'读取"jsb"中的每位教师的姓名及任教学科
Worksheets("jsb").Activate
For h = 1 To 14 '共14科！！
For l = 1 To 25
jsA(h, l) = Cells(h + 1, l + 1).Value
kmA(h, l) = Cells(h + 1, 1).Value
Next l
Next h
'end
'根据读取的jsA，kmA数据，填充"kcb"的教师姓名
Worksheets("kcb").Activate
For l = 1 To 25
For jc1 = 2 To 36
km = Cells(jc1, 2 * l).Value
For h = 1 To 14
If km = kmA(h, l) Then
Cells(jc1, 2 * l + 1).Value = jsA(h, l)
End If
Next h
Next jc1
Next l
'end
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
For i = 1 To 116
js(i) = Cells(i + 1, 2).Value
Debug.Print js(i)
Next i
'end
'获取每位任课教师任教科目的节次及班级，打开"jskcb含音乐"进行填充相关数据
For i = 1 To 116
Worksheets("kcb").Activate
For Each mycell In Range("A1:AY36")
Worksheets("kcb").Activate
If js(i) = mycell Then
jc2 = Cells(mycell.Row, 1).Value 'mycell.row 获取mycell的行号，mycell.column获取mycell的列号，这个问题困扰我很长时间，结果一查原来如此简单！！
bj = Cells(1, mycell.Column).Value
Worksheets("jskcb").Activate
For Each mycell2 In Range("A1:F1390")
If js(i) = mycell2 Then
Cells(mycell2.Row + Int(Val(Mid(jc2, 2, 1))), mycell2.Column + Int(Val(Mid(jc2, 1, 1)))).Value = bj
End If
Next mycell2
End If
Next mycell
Next i
Worksheets("jsb").Activate
For h = 1 To 14
For l = 1 To 25
jsA(h, l) = Cells(h + 1, l + 1).Value
kmA(h, l) = Cells(h + 1, 1).Value
Next l
Next h
End Sub
Sub 后期修饰()
Worksheets("jskcb").Activate
For i = 1 To 116
Range(Cells(12 * i - 9, 1), Cells(12 * i - 2, 6)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Cells(12 * i - 9, 1).Value = "节次"
Next i
End Sub
以上程序，按顺序执行即可。但要注意第1个程序，此程序的目的是用来取消合并单元格用的。取消合并后，要手动进行一下行列转置。
提取班级课程表的源程序如下：
Sub 班级课程表()
Dim jie(6) As String
Dim j As Integer
jie(1) = "节次"
jie(2) = "周一"
jie(3) = "周二"
jie(4) = "周三"
jie(5) = "周四"
jie(6) = "周五"
Dim km(36) As String
Dim k As Integer
Dim n As Integer
Dim bj As Integer
For bj = 1 To 25 '自此开始逐班设计、读取、填充
Worksheets("bjkcb").Select '此表开始应为空！
Range(Cells(11 * bj - 10, 1), Cells(11 * bj - 9, 6)).Select '设计班级课程表的表头
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Value = "高一·" + Format(Str(bj)) + "班课程表"
Selection.Font.Size = 18
Range(Cells(11 * bj - 8, 1), Cells(11 * bj - 1, 6)).Select '设计班级课程表的格式,增加修饰线
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'自此为班级课程表的标题行及列的设计过程
For j = 1 To 6
Cells(3, j).Value = jie(j)
Next j
Range("A3:F3").Copy Destination:=Range(Cells(11 * bj - 8, 1), Cells(11 * bj - 8, 6))
For j = 1 To 7
Cells(j + 3, 1).Value = Str(j)
Next j
Range("A4:A10").Copy Destination:=Range(Cells(11 * bj - 7, 1), Cells(11 * bj - 7, 1))
'至此为班级课程表的标题行及列的设计过程 end
'自此读取"课程表"中各班级所在列的数据(共35节课)
For k = 2 To 36
km(k) = Worksheets("课程表").Cells(k, bj + 1).Value
Debug.Print km(k)
Next k
'至此读取课程表中各班级所在列的数据(35节课) end
'自此为按读取的数据,打开"bjkcb"进行填充数据过程
For n = 1 To 5
Cells(11 * bj - 7, n + 1).Select
For k = 7 * n - 5 To 7 * n + 1
ActiveCell.Offset(k + 2 - 7 * n + 7 - 4, 0).Value = km(k)
Next k
Next n
'至此为按读取的数据,打开"bjkcb"进行填充数据过程 end
Next bj
'至此为逐班设计、读取、填充数据 end
End Sub
今天你菊子曰了么？