怎样从下面这张EXCEL表中提取单个老师的周课程表?

打开课程表工作表，按 Alt + F11 ，进入的代码编辑页面，将下面的代码贴入，鼠标点在代码中间位置，按 F5 运行代码
-----------------------
Sub aaa()
'复制标题行和列，将含有特定内容的单元格筛选到新表

Dim ra As Range, c As Range
Dim ar As Integer, ac As Integer
Dim stnm As String, nm As String

nm = "9" '将“9”改为要提取的老师的名字
stnm = "Sheet1" '将“Sheet1”改为数据源表（即课程表工作表）的表名

'Do While Worksheets(1).Name <> Worksheets(stnm).Name
' MsgBox "删除工作表：" & Worksheets(1).Name '提示删除工作表
' Application.DisplayAlerts = False
' Worksheets(1).Delete
' Application.DisplayAlerts = True
'Loop

ar = Worksheets(stnm).UsedRange.Rows.Count
ac = Worksheets(stnm).UsedRange.Columns.Count

Worksheets.Add before:=Worksheets(1)
'MsgBox "已创建新工作表：" & Worksheets(1).Name '提示新建工作表

Worksheets(stnm).Range(Cells(1, 1), Cells(1, ac)).Copy Worksheets(1).Cells(1, 1)
Worksheets(stnm).Range(Cells(1, 1), Cells(ar, 1)).Copy Worksheets(1).Cells(1, 1)
Application.CutCopyMode = False

'MsgBox Worksheets(stnm).Name & " " & ar & " " & ac '提示数据源表的有效数据区域

With Worksheets(stnm).Range(Cells(2, 2), Cells(ar, ac))
Set c = .Find(nm, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Copy Worksheets(1).Cells(c.Row, c.Column)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
Else
MsgBox "在表" & Worksheets(stnm) & "中没有找到“" & nm & "”"
Exit Sub
End If
End With
Worksheets(1).Activate
End Sub

---------------------
注：
nm = "9" '将“9”改为要提取的老师的名字
stnm = "Sheet1" '将“Sheet1”改为数据源表（即课程表工作表）的表名

效果图在我的空间
http://hi.baidu.com/sxpose/blog/item/9e01164d1a087205b3de05d1.html

有其他问题Hi我

如果你仅仅是为了显示和打印的话我有一个办法。
第一步 找一个没有用到的单元格（比如 Z1）
第二步 选中所有的课程名称（不要选第一行和第一列）设置字体的颜色是白色。所有课程都看不到了。
第三步 设置这些单元格的 条件格式 为 =z1 时 字体颜色是 黑色(要指定为黑色，默认的自动，已经被你设成白色了)
这时在z1中输入一个课程，比如“中国税制谭晖”，对应的课表中的课程会显示出来

点击上方工具栏的“数据”，再点“筛选”，自动或高级筛选随你自己的需要了。

请举例说明所需周课程表的格式布局！