'日期添加 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 Next End 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 = Range("e" & (i - 1)).Value End If Next End 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 Sub Sub 生成周课表() ' ' 生成周课表 宏 ' ' 快捷键: 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 '生成总周课表 totalSheet End Sub Sub 查看上课情况() 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 = 0 End Sub