‘日期添加Sub addDate(d)    Dim rg As Range, dd As Date        d = Split(d, "-")(0)    d = Replace(d, ".", "/")    dd = CDate(d)    r = ActiveSheet.Range("a65536").End(xlUp).Row    ‘[d2] = dd    Dim i As Integer ‘一天8次课，循环4次结束一天    i = 0    For Each rg In Range("D2:D" & r)        i = i + 1        If i = 4 Then            i = 0            dd = rg.Offset(-1, 0).Value + 1        End If        rg = dd    NextEnd Sub‘创建新表Sub createsheet(sname)    On Error Resume Next    Set ws = Worksheets(sname)    If ws Is Nothing Then        Set ws = Worksheets.Add        ws.Name = sname    Else        ws.Cells.Clear    End If    ws.Range("a1:j1") = Array("周序", "简称", "教学班次", "日期", "星期", "节次", "课程名称", "任课教员", "上课地点", "页码")End Sub‘拆开合并单元格Sub devideMerge()    Dim r As Integer, rg As Range, i As Integer        r = Range("a65536").End(xlUp).Row    For i = 2 To r        If (Range("e" & i).MergeCells) Then Range("e" & i).UnMerge        tempValue = Range("e" & i).Value        If (tempValue = "") Then            Range("E" & i).Value = http://www.mamicode.com/Range("e" & (i - 1)).Value                    End If   NextEnd Sub‘删除空行Sub delBlank()    Dim c As Range, r As Integer    r = Range("a1").CurrentRegion.Rows.Count        For i = 2 To r        Set c = Range("b" & i)        If c.MergeCells Then c.EntireRow.Delete    Next        r = Range("a1").CurrentRegion.Rows.Count         For i = r To 2 Step -1        Set c = Range("b" & i)        If c.MergeCells Or IsEmpty(c) Then c.EntireRow.Delete    Next  End Sub‘生成总周课表Sub totalSheet()    On Error Resume Next    strname = "总周课表"     Dim ws As Worksheet, obj As Worksheet, r As Integer         Set ws = Worksheets(strname)    If ws Is Nothing Then      Set ws = Worksheets.Add       ws.Name = strname    Else        ws.Cells.Clear    End If    ws.Range("a1:j1") = Array("周序", "简称", "教学班次", "日期", "星期", "节次", "课程名称", "任课教员", "上课地点", "页码")       For Each obj In Worksheets        If (obj.Name <> strname And obj.Name Like "*-周课表") Then             r = obj.UsedRange.Rows.Count                        obj.Select            obj.Rows("2:" & r).Select            Selection.Copy            ws.Select            ws.Range("a65536").End(xlUp).Offset(1, 0).Select            ActiveSheet.Paste                           ‘选中一个单元格            obj.Range("a1").Select        End If    Next    ws.Range("a1").Select    End SubSub 生成周课表()‘‘ 生成周课表 宏‘‘ 快捷键: Ctrl+k‘    Application.ScreenUpdating = False        Const copycol = 28    Dim ws As Worksheet, cws As Worksheet, upNo As Integer, r As Integer, cname As String, rg As Range, str As String, curRow        For Each ws In Worksheets        ‘创建新表－周课表        cname = ws.Name + "-周课表"        createsheet cname        Set cws = Worksheets(cname)                upNo = ws.Range("a:a").Find("序号").Row                ‘开始复制内容        For i = 4 To upNo - 1            curRow = 28 * (i - 4) + 2            ‘简称            ws.Range("C" & i & ":AD" & i).Copy            cws.Range("B" & curRow & ":B" & curRow * copycol).Select            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _            False, Transpose:=True            ‘节次            ws.Range("C3:AD3").Copy            cws.Range("f65536").End(xlUp).Offset(1, 0).Select            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _            False, Transpose:=True            ‘星期            ws.Range("C2:AD2").Copy            cws.Range("E65536").End(xlUp).Offset(1, 0).Select            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _            False, Transpose:=True                                        ‘周序            str = ws.Range("a" & i).Value            cws.Range("a65536").End(xlUp).Offset(1, 0).Resize(copycol, 1).Select            Selection = str                                       Next        ‘日期处理        cws.Select        addDate ws.Range("b4").Value                            ‘删除空行        r = cws.Range("a65536").End(xlUp).Row        delBlank                 ‘课程名称        str = ws.Range("f1").Value        cws.Range("C65536").End(xlUp).Offset(1, 0).Resize(cws.Range("a65536").End(xlUp).Row - 1, 1).Select        Selection = str                ‘页码        str = ws.Range("aa65536").End(xlUp).Value        cws.Range("J65536").End(xlUp).Offset(1, 0).Resize(cws.Range("a65536").End(xlUp).Row - 1, 1).Select        Selection = str                ‘查找         r = ws.Range("a65536").End(xlUp).Row        For k = upNo + 2 To r            Set rg = ws.Range("g" & k)            If Not IsEmpty(rg) And Not rg.MergeCells Then                For g = 2 To cws.Range("b65536").End(xlUp).Row                    Set crg = cws.Range("b" & g)                    If (crg.Value = rg.Value) Then                                              cws.Range("G" & g) = ws.Range("b" & k).Value ‘课程名称                       cws.Range("H" & g) = ws.Range("n" & k).Value   ‘任课教员                       cws.Range("I" & g) = ws.Range("AA" & k).Value  ‘上课地点                    End If                Next            End If        Next        ‘把星期重新分开        devideMerge                ‘添加边框        cws.UsedRange.Borders.LineStyle = xlContinuous    Next    Application.ScreenUpdating = True        ‘生成总周课表    totalSheetEnd SubSub 查看上课情况()    Application.ScreenUpdating = False        Dim jc As String, username As String, startRow As Integer, lastRow As Integer        Dim curWs As Worksheet, ws As Worksheet, rg As Range        Set curWs = ActiveSheet        username = curWs.Range("af2").Value    If Len(username) = 0 Then        MsgBox "请在AF2单元格添写上课教员"        Range("af1") = "上课教员:"        Range("af2").Select        Exit Sub    End If        ‘标记当前活动表    startRow = curWs.Range("a:a").Find("序号").Row    lastRow = curWs.Range("a:a").Find("序号").End(xlDown).End(xlDown).Row    ‘MsgBox startRow & ":" & lastRow    ‘找教员上的课程简称    For x = startRow + 2 To lastRow - 1               If (curWs.Range("n" & x).Value Like "*" & username & "*") Then                    jc = curWs.Range("g" & x).Value           ‘简称不能为空           If (jc <> "") Then                ‘如果找到就从课表中寻找上的课并添加底色                For Each rg In curWs.Range("c4:ad" & startRow - 1)                    If rg.Value = jc Then ‘找到                        rg.Interior.ColorIndex = 39                    End If                Next            End If        End If    Next    MsgBox "表有" & Worksheets.Count    ‘循环所有表除了本表外    For Each ws In Worksheets        If (ws.Name <> curWs.Name) Then           startRow = ws.Range("a:a").Find("序号").Row           lastRow = ws.Range("a:a").Find("序号").End(xlDown).End(xlDown).Row                      ‘找教员上的课程简称           For i = startRow + 2 To lastRow - 1              If (Range("n" & i).Value Like "*" & username & "*") Then                             jc = ws.Range("g" & i).Value                ‘从所有单元格中找                ‘ MsgBox jc                    If (jc <> "") Then                         For Each rg In ws.Range("c4:ad" & startRow - 1)                            If rg.Value = jc Then ‘找到                                curWs.Range(rg.Address).Interior.ColorIndex = 39                            End If                        Next                    End If              End If           Next                   End If            Next    Application.ScreenUpdating = True    End Sub‘清楚背景色标记Sub 清楚背景色标记()   ActiveSheet.Cells.Interior.ColorIndex = 0End Sub