'日期添加
Sub addDate(d)
Dim rg As Range, dd As Date d = Split(d, "-")()
d = Replace(d, ".", "/")
dd = CDate(d)
r = ActiveSheet.Range("a65536").End(xlUp).Row
'[d2] = dd
Dim i As Integer '一天8次课，循环4次结束一天
i =
For Each rg In Range("D2:D" & r)
i = i +
If i = Then
i =
dd = rg.Offset(-, ).Value +
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 = 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 - )).Value End If
Next
End Sub
'删除空行
Sub delBlank()
Dim c As Range, r As Integer
r = Range("a1").CurrentRegion.Rows.Count For i = 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 Step -
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(, ).Select
ActiveSheet.Paste '选中一个单元格
obj.Range("a1").Select
End If
Next
ws.Range("a1").Select End Sub Sub 生成周课表()
'
' 生成周课表 宏
'
' 快捷键: Ctrl+k
'
Application.ScreenUpdating = False Const copycol =
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 = To upNo -
curRow = * (i - ) +
'简称
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(, ).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'星期
ws.Range("C2:AD2").Copy
cws.Range("E65536").End(xlUp).Offset(, ).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True '周序
str = ws.Range("a" & i).Value
cws.Range("a65536").End(xlUp).Offset(, ).Resize(copycol, ).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(, ).Resize(cws.Range("a65536").End(xlUp).Row - , ).Select
Selection = str '页码
str = ws.Range("aa65536").End(xlUp).Value
cws.Range("J65536").End(xlUp).Offset(, ).Resize(cws.Range("a65536").End(xlUp).Row - , ).Select
Selection = str '查找
r = ws.Range("a65536").End(xlUp).Row
For k = upNo + To r
Set rg = ws.Range("g" & k)
If Not IsEmpty(rg) And Not rg.MergeCells Then
For g = 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) = 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 + To lastRow - 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 - )
If rg.Value = jc Then '找到
rg.Interior.ColorIndex =
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 + To lastRow -
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 - )
If rg.Value = jc Then '找到
curWs.Range(rg.Address).Interior.ColorIndex =
End If
Next
End If
End If
Next End If Next
Application.ScreenUpdating = True End Sub '清楚背景色标记
Sub 清楚背景色标记()
ActiveSheet.Cells.Interior.ColorIndex =
End Sub