关于课程表的再次修订
关于课程表的程序编写，这已经是第二次修订了，暑假开学前为高一、高二、高三准备了课程表，期间也发现了不少问题，现在想对以前的问题做一个修正，以便于下次再用时可以更具通用性。
1.首先要有一张全年级的总课程表，样式如图所示：（工作表名字：kcb)
其中A列表示节次，第1行由B列以后表示班级，要求：班级必须是由小到大依次排列。为什么首先要求有总课程表（kcb）呢？因为一张课程表排完后，靠人工很难保证不会出现重课现象，而检测重课就是做好课表的第一步工作，思路就是利用kcb填充上教师姓名，然后检测同一行中是否会重名现象，若有，必是重课现象，就可以进行修正了。基于以上考虑，在编写时就首先要有这张表才可以。同时若非得需要一个教师同时带两个班或多个班，那也可以不进行检测，后面在编写教师课表时已经考虑进来此种现象了。
2.提供了kcb后就可以插入对应的教师姓名，检测重复项，对kcb进行修正，保证无误。（要保证年级里面没有重名的教师，若有必须进行处理，高二年级的课程表就出现了这个现象。），所以下面就需要提供任课教师表（jsb)，样式如图所示：
对于我们有个地方需要注意：由于编班时考虑所谓的走班问题，导致了班号并不是连着的，而跳着编排的，所以在整理jsb时就要事先整理一下才可以，这里需要进行两步工作：①由于此表是由任课教师表转换而来，所以需要解决掉合并单元格问题，然后②再按行列转置后，按行对班号进行排序。此时得到的表就如上图所示。
关于取消合并单元格并将单元格内容进行保留的源程序如下：
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("jsb").Activate
totalR = Range("B65536").End(xlUp).Row
totalC = Range("IV1").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 introw As Integer, i As Integer, intcolumn As Integer, j As Integer
Application.DisplayAlerts = False
introw = Range("A65536").End(xlUp).Row
intcolumn = Range("IV1").End(xlToLeft).Column
Debug.Print intcolumn
For j = 1 To intcolumn
For i = introw To 2 Step -1
If Cells(i, j).Value = Cells(i - 1, j).Value Then
Range(Cells(i - 1, j), Cells(i, j)).Merge
End If
Next i
Next j
Application.DisplayAlerts = True
End Sub
得到上表后，就可以填充js列了。这也是第一步需要处理的工作，源程序如下：
Option Base 1
Sub 在kcb中插入JS列()
Dim totalR As Integer, i As Integer
Dim totalC As Integer
Worksheets("kcb").Activate
' Cells(1, 1).EntireColumn.Insert
totalC = Range("IV1").End(xlToLeft).Column
Debug.Print totalC
For i = 2 To totalC
Cells(1, 2 * i - 1).EntireColumn.Insert
Next i
For i = 2 To totalC
Cells(1, 2 * i - 1).Value = "js" + Trim(Str(i - 1))
Next i
End Sub
Sub 填充kcb的老师姓名()
Dim jsA() As String
Dim kmA() As String
Dim km As String
Dim jc As Integer
Dim h As Integer, l As Integer
Dim kms As Integer, totalC As Integer, totalR As Integer
'读取"jsb"中的每位教师的姓名及任教学科
Worksheets("jsb").Activate
kms = Range("A65536").End(xlUp).Row - 1
totalC = Range("IV1").End(xlToLeft).Column - 1
ReDim jsA(kms, totalC)
ReDim kmA(kms, totalC)
For h = 1 To kms
For l = 1 To totalC
jsA(h, l) = Cells(h + 1, l + 1).Value
kmA(h, l) = Cells(h + 1, 1).Value
Debug.Print jsA(h, l), kmA(h, l)
Next l
Next h
'根据读取的jsA，kmA数据，填充"kcb"的教师姓名
Worksheets("kcb").Activate
totalR = Range("A65536").End(xlUp).Row
For l = 1 To totalC
For jc = 2 To totalR '一天7节课，5天共35节课，到36行结束。
km = Cells(jc, 2 * l).Value
For h = 1 To kms
If km = kmA(h, l) Then
Cells(jc, 2 * l + 1).Value = jsA(h, l)
End If
Next h
Next jc
Next l
Cells.Columns.AutoFit
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
'在修正完重复信息后，将头两个程序再执行一遍，就可以得到完整的信息，执行下面的程序，删掉js列，然后进行提取班级课程表
Sub 删除js列()
Dim totalC As Integer, i As Integer
Worksheets("kcb").Activate
totalC = Range("IV1").End(xlToLeft).Column
For i = totalC To 1 Step -1
If Left(Cells(1, i).Value, 2) = "js" Then
Cells(1, i).EntireColumn.Delete
End If
Next i
End Sub
3.提取班级课程表。此时由于已经消耗的时间太多，别人已经有点没耐心了，先将班级课程表提取出来，让他们先有点成就感。
需要建立一个空表（bjkcb)，此表用来存储班级课程表的结果，并且格式已经设置好，为B5格式，一班一页。
源程序如下：
Sub 提取班级课程表()
'务必执行上面的程序先将js列删除，便于提取班级课程表
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
Worksheets("bjkcb").Activate
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
Worksheets("kcb").Activate
totalC = Range("IV1").End(xlToLeft).Column - 1
For bj = 1 To totalC '自此开始逐班设计、读取、填充
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 = 36
Selection.Font.Name = "华文新魏"
Selection.RowHeight = 60
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("kcb").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
For i = 1 To totalC
Range(Cells(3 + (i - 1) * 11, 1), Cells(3 + 7 + (i - 1) * 11, 6)).Select
Selection.Font.Name = "微软雅黑"
Selection.Font.Size = 20
Selection.RowHeight = 60
Selection.ColumnWidth = 12
Next i
Cells.Select
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
End Sub
最终的kcb样式不再截图，保证没问题就是了。
4.进行教师课表的提取。需要建立一个空表（jskcb），用来存储教师课表的结果。需要一个教师代码表（jsdmb），格式如下图所示：
源程序如下：
Sub 老师课程表表格模式设计()
Dim js() As String
Dim totalR As Integer
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
ReDim js(totalR)
For i = 1 To totalR
js(i) = Cells(i + 1, 2).Value
Next i
'end
'设计教师课表的表头部分
Worksheets("jskcb").Activate
For i = 1 To totalR
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
'设计教师课表的行头及列头标题
'注意请先在表中的A3：A10依次填入节次、1,2,3,4,5,6,7；A3：F3依次填入节次，周一，周二，周三，周四，周五，便于下面复制。
For i = 1 To totalR
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 totalR
Cells(12 * i - 9, 1).Value = js(i)
Next i
End Sub
Sub 教师课表()
Dim km As String
Dim js() As String
Dim bj As String
Dim myCell, mycell2 As Range
Dim jc2 As String
Dim h As Integer, i As Integer, l As Integer
Dim totalR As Integer
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
ReDim js(totalR)
For i = 1 To totalR
js(i) = Cells(i + 1, 2).Value
Next i
'end
'获取每位任课教师任教科目的节次及班级，打开"jskcb"进行填充相关数据
For i = 1 To totalR
Worksheets("kcb").Activate
For Each myCell In Range(Cells(1, 1), Cells(36, Range("IV1").End(xlToLeft).Column))
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(Cells(1, 1), Cells(Range("A65536").End(xlUp).Row, 6))
If js(i) = mycell2 Then
Cells(mycell2.Row + Int(Val(Mid(jc2, 2, 1))), mycell2.Column + Int(Val(Mid(jc2, 1, 1)))).Value = 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
Worksheets("kcb").Activate
Next myCell
Debug.Print "第" & Str(i) & "位教师:" & js(i) & "已经完成,还余:" & Str(totalR - i) & "位!!,请耐心等待!!"
Next i
End Sub
Sub 教师课表的后期修饰()
Dim totalR As Integer
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
Worksheets("jskcb").Activate
For i = 1 To totalR
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
程序到此结束。需要用到的工作表如下图所示：
即bjkcb jskcb kcb jsdmb jsb共五个工作表。
最终完整的源程序如下：
Option Base 1
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("jsb").Activate
totalR = Range("B65536").End(xlUp).Row
totalC = Range("IV1").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 introw As Integer, i As Integer, intcolumn As Integer, j As Integer
Application.DisplayAlerts = False
introw = Range("A65536").End(xlUp).Row
intcolumn = Range("IV1").End(xlToLeft).Column
Debug.Print intcolumn
For j = 1 To intcolumn
For i = introw To 2 Step -1
If Cells(i, j).Value = Cells(i - 1, j).Value Then
Range(Cells(i - 1, j), Cells(i, j)).Merge
End If
Next i
Next j
Application.DisplayAlerts = True
End Sub
Sub 在kcb中插入JS列()
Dim totalR As Integer, i As Integer
Dim totalC As Integer
Worksheets("kcb").Activate
' Cells(1, 1).EntireColumn.Insert
totalC = Range("IV1").End(xlToLeft).Column
Debug.Print totalC
For i = 2 To totalC
Cells(1, 2 * i - 1).EntireColumn.Insert
Next i
For i = 2 To totalC
Cells(1, 2 * i - 1).Value = "js" + Trim(Str(i - 1))
Next i
End Sub
Sub 填充kcb的老师姓名()
Dim jsA() As String
Dim kmA() As String
Dim km As String
Dim jc As Integer
Dim h As Integer, l As Integer
Dim kms As Integer, totalC As Integer, totalR As Integer
'读取"jsb"中的每位教师的姓名及任教学科
Worksheets("jsb").Activate
kms = Range("A65536").End(xlUp).Row - 1
totalC = Range("IV1").End(xlToLeft).Column - 1
ReDim jsA(kms, totalC)
ReDim kmA(kms, totalC)
For h = 1 To kms
For l = 1 To totalC
jsA(h, l) = Cells(h + 1, l + 1).Value
kmA(h, l) = Cells(h + 1, 1).Value
Debug.Print jsA(h, l), kmA(h, l)
Next l
Next h
'根据读取的jsA，kmA数据，填充"kcb"的教师姓名
Worksheets("kcb").Activate
totalR = Range("A65536").End(xlUp).Row
For l = 1 To totalC
For jc = 2 To totalR '一天7节课，5天共35节课，到36行结束。
km = Cells(jc, 2 * l).Value
For h = 1 To kms
If km = kmA(h, l) Then
Cells(jc, 2 * l + 1).Value = jsA(h, l)
End If
Next h
Next jc
Next l
Cells.Columns.AutoFit
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 删除js列()
Dim totalC As Integer, i As Integer
Worksheets("kcb").Activate
totalC = Range("IV1").End(xlToLeft).Column
For i = totalC To 1 Step -1
If Left(Cells(1, i).Value, 2) = "js" Then
Cells(1, i).EntireColumn.Delete
End If
Next i
End Sub
Sub 提取班级课程表()
'务必执行上面的程序先将js列删除，便于提取班级课程表
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
Worksheets("bjkcb").Activate
Cells.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
Worksheets("kcb").Activate
totalC = Range("IV1").End(xlToLeft).Column - 1
For bj = 1 To totalC '自此开始逐班设计、读取、填充
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 = 36
Selection.Font.Name = "华文新魏"
Selection.RowHeight = 60
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("kcb").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
For i = 1 To totalC
Range(Cells(3 + (i - 1) * 11, 1), Cells(3 + 7 + (i - 1) * 11, 6)).Select
Selection.Font.Name = "微软雅黑"
Selection.Font.Size = 20
Selection.RowHeight = 60
Selection.ColumnWidth = 12
Next i
Cells.Select
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
End Sub
Sub 老师课程表表格模式设计()
Dim js() As String
Dim totalR As Integer
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
ReDim js(totalR)
For i = 1 To totalR
js(i) = Cells(i + 1, 2).Value
Next i
'end
'设计教师课表的表头部分
Worksheets("jskcb").Activate
For i = 1 To totalR
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
'设计教师课表的行头及列头标题
'注意请先在表中的A3：A10依次填入节次、1,2,3,4,5,6,7；A3：F3依次填入节次，周一，周二，周三，周四，周五，便于下面复制。
For i = 1 To totalR
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 totalR
Cells(12 * i - 9, 1).Value = js(i)
Next i
End Sub
Sub 教师课表()
Dim km As String
Dim js() As String
Dim bj As String
Dim myCell, mycell2 As Range
Dim jc2 As String
Dim h As Integer, i As Integer, l As Integer
Dim totalR As Integer
'顺序读取任课教师姓名
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
ReDim js(totalR)
For i = 1 To totalR
js(i) = Cells(i + 1, 2).Value
Next i
'end
'获取每位任课教师任教科目的节次及班级，打开"jskcb"进行填充相关数据
For i = 1 To totalR
Worksheets("kcb").Activate
For Each myCell In Range(Cells(1, 1), Cells(36, Range("IV1").End(xlToLeft).Column))
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(Cells(1, 1), Cells(Range("A65536").End(xlUp).Row, 6))
If js(i) = mycell2 Then
Cells(mycell2.Row + Int(Val(Mid(jc2, 2, 1))), mycell2.Column + Int(Val(Mid(jc2, 1, 1)))).Value = 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
Worksheets("kcb").Activate
Next myCell
Debug.Print "第" & Str(i) & "位教师:" & js(i) & "已经完成,还余:" & Str(totalR - i) & "位!!,请耐心等待!!"
Next i
End Sub
Sub 教师课表的后期修饰()
Dim totalR As Integer
Worksheets("jsdmb").Activate
totalR = Range("A65536").End(xlUp).Row - 1
Worksheets("jskcb").Activate
For i = 1 To totalR
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
