如何提取班级及任课教师课程表

以前都是要麻烦别人，但现在自己也可以解决了。

首先要保证一点：教师姓名必须要保持一致，写的过程就发现了有些老师的姓名前后不一致导致最终结果里面没有他们的课程表（为空）。

需要准备的文件（所有表格均存放在同一工作簿中）：

①任课教师表（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

 今天你菊子曰了么？

转载于:https://www.cnblogs.com/xiehui/archive/2010/03/26/2004308.html