Excel VBA对象2

4.3.1 Workbook对象是Workbooks集合中的一个成员
2. 怎样引用集合中的某个工作簿
法一：使用索引号引用工作簿
要引用Workbooks集合中的第3个Workbook，可以将代码写为：
Workbooks.Item(3)
使用时可以省略属性名称Item，将代码写为：
Workbooks(3)

法二：利用工作簿名引用工作簿
Workbooks("Book1")
Workbooks("Book1.xlsm")

? Workbooks("Book1").Name
? Workbooks("Book1.xlsm").Name

4.3.2 访问对象的属性，获得工作簿文件的信息
Sub WbMsg()
    Range("B2") = ThisWorkbook.Name
    Range("B3") = ThisWorkbook.Path
    Range("B4") = ThisWorkbook.FullName
End Sub

4.3.3 用Add方法创建工作簿
Workbooks.Add
Workbooks.Add Template:="D:\我的文件\模板.xlsm"
Workbooks.Add "D:\我的文件\模板.xlsm"

4.3.4 用Open方法打开工作薄
Workbooks.Open Filename:="D:\我的文件\模板.xlsm"
Workbooks.Open "D:\我的文件\模板.xlsm"

4.3.5 用Activate方法激活工作簿
虽然可以同时打开多个工作簿文件，但同一时间只能有一个工作簿是活动的。如果想让不活动的工作簿变为活动的工作簿，可以用Workbooks对象的Activate方法激活它，例如：

Workbooks("工作簿1").Activate

4.3.8 ThisWorkbook与ActiveWorkbook
ThisWorkbook 和 ActivateWorkbook 都是Application对象的属性，都返回Workbook对象。但是，它们之间并不是等同的。ThisWorkbook是对代码所在的工作簿的引用，ActiveWorkbook是对活动工作簿的引用。

Sub wb()
    Workbooks.Add
    MsgBox "代码所在的工作簿为：" & ThisWorkbook.Name
    MsgBox "当前活动工作簿为：" & ActiveWorkbook.Name
    ActiveWorkbook.Close savechanges:=False
End Sub

4.4 操作工作表，认识Worksheet对象
4.4.1 引用工作表的3种方法
Worksheets.Item(3)          '引用工作簿中的第3张工作表
Worksheets(3)               '引用工作簿中的第3张工作表
Worksheets("ExcelHome")     '引用工作簿中标签名称为"ExcelHome"的工作表

与使用索引号或标签名称引用工作表不同，使用代码名称引用工作表，只需直接写代码名称而不需先写集合名称Worksheets，例如：
Sheet3.Range("A1")=100 '在代码名称为sheet3的工作表的A1单元格输入100
注意Range("A1")与Range("A1").Value的区别
Range("A1").Value = 700
Range("A1") = 700

如果想获得某张工作表的代码名称，可以访问工作表的CodeName属性，例如：
MsgBox ActiveSheet.CodeName '用对话框显示活动工作表的代码名称

4.5 操作的核心，至关重要的Range对象
4.5.1 用Range属性引用单元格
1. 引用单个固定的单元格区域
Sub rng()
    Range("A1:A10").Value = 200     '在活动工作表的A1:A10输入数值200
    Dim n As String
    n = "B1:B10"
    Range(n) = 100                  '在当前活动工作表的B1:B10输入数值100
End Sub

要引用定义为名称的单元格，可以将Range属性的参数设置为表示名称名的字符串或变量，例如：
Range("C_Date").Value = 100

2. 引用多个不连续的单元格区域
Range("A1:A10,A4:E6,C3:D9").Select '选中多个不连续的单元格区域

3. 引用多个区域的公共区域
Range("B1:B10 A4:D6").Value = 100 '在两个单元格区域的公共区间输入100
'尽管中间有空格，但参数只是一个字符串

4. 引用两个区域围成的矩形区域
Range("B6:B10","D2:D8").Select '两个参数间用逗号分隔

插入一列
Columns(4).Resize(, 1).Insert Shift:=xlToRight
Columns("A:A").Insert Shift:=xlToRight

Range("C1").Select
ActiveSheet.Rows(Selection.Row).Insert
ActiveSheet.Columns(Selection.Column).Insert

Range("C1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove

Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '插入一整行 ，单元格的移动方向向下，插入的行格式随上面行的格式

4.5.2 用Cells属性引用单元格
1. 引用工作表中指定行列交叉的单元格
ActiveSheet.Cells(3, 4).Value = 20
ActiveSheet.Cells(3, "D").Value = 20

在使用Cells引用工作表中的某个单元格时，总是可以将代码写为：
工作表对象.Cells(行号, 列标)

2. 引用单元格区域中的某个单元格
Range("B3:F9").Cells(2,3) = 100 '在B3:F9区域的第2行与第3列交叉的单元格中输入100

3. 将Cells属性的返回结果设置为Range属性的参数
还可以将Cells属性设置为Range属性的参数，例如：
Range(Cells(1, 1), Cells(10, 5)).Select '选中当前工作表的A1:E10单元格
这行代码和下面的两行代码是等效的
Range("A1", "E10").Select
Range(Range("A1"), Range("E10")).Select

4. 使用索引号引用单元格
Cells是工作表中所有单元格组成的集合，可以使用索引号引用该集合中的某个单元格，例如：
ActiveSheet.Cells(2).Value = 200 '在活动工作表的第二个单元格输入200

4.5.3 引用单元格，更简短的快捷方式
[B2]                    'B2单元格
[A1:D10]                'A1:D10单元格区域
[A1:A10,C1:C10,E1:E10]  '三个单元格区域的并集
[B1:B10 A5:D5]          '两个单元格区域的公共部分
[n]                     '被定义为名称n的单元格区域

4.5.4 引用整行单元格
ActiveSheet.Rows("3:3").Select  '选中活动工作表的第3行
ActiveSheet.Rows("3:5").Select  '选中活动工作表的第3行到第5行
'Rows返回其父对象(ActiveSheet)中所有行组成的集合，参数是表示行的名称的字符串或字符串变量

如果使用索引号引用整行，代码为：
ActiveSheet.Rows(3).Select  '选中活动工作表中的第3行
'3是索引号，表示引用父对象(ActiveSheet)中的第3行

如果要引用工作表中的所有行，代码为：
ActiveSheet.Rows.Select     '选中活动工作表中的所有行
'如果不给Rows属性设置参数，则表示引用集合中的所有行，效果等同于 ActiveSheet.Cells

如果引用Range对象的Rows属性，则返回单元格区域中的指定行，例如：
Rows("3:10").Rows("1:1").Select

4.5.5 引用整列单元格
ActiveSheet.Column("F:G").Select        '选中活动工作表中的F到G列
ActiveSheet.Columns(6).Select           '选中活动工作表中的第6列
ActiveSheet.Columns.Select              '选中活动工作表中的所有列
Columns("B:G").Columns("B:B").Select    '选中B:G列区域中的第2列

4.5.6 用Union方法合并多个单元格区域
Application.Union(Range("A1:A10"), Range("D1:D5")).Select '同时选中两个区域

试题：选中活动工作表A1:A10单元格区域中与A1单元格内容相同的所有单元格。
Sub Sel()
    Dim myrange As Range, n As Range
    Set myrange = Range("A1")
    For Each n In Range("A1:A10")
        If n.Value=Range("A1").Value Then
            Set myrange = Union(myrange,n)
        End if
    Next n
    myrange.Select
End Sub

4.5.7 Range对象的Offset属性
Range对象的Offset属性，作用类似工作表中的Offset函数。
使用Offset属性，可以获得相对于指定单元格区域一定偏移量位置上的单元格区域。例如：
Range("A1").Offset(4, 0).Value = 500 '在A1下方的第4个单元格中输入数值500
'Offset通过括号中的两个参数确定要返回的单元格

Offset属性有两个参数，分别用来设置该属性的父对象在上下或左右方向上偏移的行列数，例如：
Range("B2:C3").Offset(5, 3).Value = 500
Range("D7:F8").Offset(-5, -2).Value = 500

4.5.8 Range对象的Resize属性
使用Range对象的Resize属性可以将指定的单元格区域有目的地扩大或缩小，得到一个新的单元格区域，例如：

Range("B2").Resize(5, 4).Select '将B2扩展为一个5行4列的单元格区域
'Resize属性把该对象最左上角的单元格当成返回结果最左上角的第1个单元格
'Resize属性的参数用来确定返回区域的行数和列数，第1参数用于确定行数，第2参数用于确定列数，两个参数都应设置为正整数。

4.5.9 Worksheet对象的UsedRange属性
Worksheet对象的UsedRange属性返回工作表中已经使用的单元格围成的矩形区域，无论这些区域中间是否存在空行、空列或空单元格。


ActiveSheet.UsedRange.Select '选中活动工作表中已经使用的单元格区域


4.5.10 Range对象的CurrentRegion属性
Range对象的CurrentRegion属性返回包含指定单元格在内的一个连续的矩形区域


Range("B5").CurrentRegion.Select '等同于在选中B5单元格的同时，按【F5】键，定位【当前区域】得到的单元格区域。空行及下面的区域，以及空列及右边的区域不包含在CurrentRegion属性返回的区域中。


4.5.11 Range对象的End属性
Range对象的End属性返回包含指定单元格的区域最尾端的单元格，返回结果等同于在单元格中按【End+方向键】组合键得到的单元格。


MsgBox Range("C5").End(xlUp).Address '用对话框显示End属性返回单元格的地址
'参数xlUp告诉VBA，End属性返回的时区域中最上方的单元格
'End属性返回的是在C5单元格中，按【End+上方向键】组合键得到的单元格


其他可设置的参数
xlToLeft
xlToRight
xlUp
xlDown


当使用程序向一张工作表中添加数据时，我们希望将数据添加到工作表的第1个空单元格中。要让程序往单元格中录入数据，首先得确定第1个空单元格是哪个单元格，End属性就可以解决这一问题


ActiveSheet.Range("A1048576").End(xlUp).Offset(1,0).Value = "刘伟"
'在A列最后一个单元格按【End+上方向键】组合键，即可得到A列最后一个非空单元格
'最后一个非空单元格向下偏移一行，即可得到第一个空单元格，该单元格即为要输入数据的单元格
'有一点需要注意，如果A列全为空单元格，那Range("A1048576").End(xlUp)返回的是A1单元格，同样的代码实际上是在A2单元格输入数据。要解决这一问题，可以在单元格中输入数据前，使用If语句判断End属性返回的结果是否为空单元格，再根据判断结果选择应该在哪个单元格输入数据。


Option Explicit


Sub RngEnd_2()
    Dim c As Range
    Set c = ActiveSheet.Range("A1048576").End(xlUp)
    If c.Value <> "" Then
        c.Offset(1, 0).Value = "刘伟"
    Else
        c.Value = "刘伟"
    End If
End Sub


4.5.12 单元格中的内容：Value属性
Range("A1:B2").Value = "abc" '在A1:B2中输入abc


Range("B1").Value = Range("A1").Value '把A1单元格中的数据写入B1单元格中


Value是Range对象的默认属性，在给区域赋值时，可以省略属性名称，将代码写为：
Range("A1:B2") = "abc" '在A1:B2单元格中输入abc


4.5.13 访问Count属性，获得区域中包含的单元格个数
Range对象的Count属性返回指定单元格区域中包含的单元格个数，如果想知道B4:F10单元格区域一共有多少个单元格，可以用代码：
Range("B4:F10").Count
如果想知道某个区域包含的行数或列数，可以用代码
ActiveSheet.UsedRange.Rows.Count '活动工作表中已使用区域包含的行数
ActiveSheet.UsedRange.Columns.Count '活动工作表中已使用区域包含的列数


4.5.14 通过Address属性获得单元格的地址
想知道某个单元格的地址，可以访问它的Address属性，例如：
MsgBox "当前选中的单元格地址为：" & Selection.Address


4.5.15 用Activate与Select方法选中单元格
要选中一个单元格区域，可以使用Range对象的Activate方法和Select方法，例如：
ActiveSheet.Range("A1:F5").Activate '选中活动工作表中的A1:F5
ActiveSheet.Range("A1:F5").Select '选中活动工作表中的A1:F5

4.5.16 选择清除单元格中的信息

'清除B2单元格中所有的信息(包括批注、内容、格式、超链接等)
Range("B2").Clear

'清除B2单元格中的批注
Range("B2").ClearComments

'清除B2单元格中的内容
Range("B2").ClearContents

'清除B2单元格中的格式
Range("B2").ClearFormats

'清除B2单元格中的超链接
Range("B2").ClearHyperlinks

4.5.17 用Copy方法复制单元格区域

录制宏示例：

Sub CopyTest()
    Range("A1").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
End Sub

该录制宏代码有冗余，在使用VBA代码复制单元格时，并不需要选中单元格，所以如果要将A1单元格复制到C1单元格，可用如下代码：
Range("A1").Copy Range("C1")
其中Range("C1")是Copy方法的参数(省略了参数名)，用来指定目标单元格。未省略参数名称的语句应为：
Range("A1").Copy Destination:=Range("C1")

综上，一个复制单元格的语句，总是可以写成这样的结构：
原单元格区域.Copy Destination:=目标单元格
其中参数名称Destination可以省略

有一点需要说明，无论复制的区域包含多少个单元格，在设置目标区域时，都可以只指定一个单元格作为目标区域最左上角的单元格即可
例如：
Range("A1").CurrentRegion.Copy Destination:=Range("G1")

怎样只粘贴区域中的数值而不带格式等其他内容？

Sub CopyValues()
    Range("A1:D10").Copy
    Range("F1:I10").PasteSpecial Paste:=xlPasteValues
End Sub

或
Sub CopyValues()
    Range("F1:I10").Value = Range("A1:D10").Value
End Sub

4.5.18 用Cut方法剪切单元格
使用Cut方法可以将一个单元格区域剪切到另一个单元格区域。
剪切单元格和复制单元格，除方法名称不同外，其他基本相似。
Range("A1:E5").Cut Destination:=Range("G1") '把A1:E5剪切到G1：K5
Range("A1").Cut Range("G1") '把A1剪切到G1

4.5.19 用Delete方法删除指定的单元格

删除B3所在的整行单元格
Range("B3").EntireRow.Delete

删除B5单元格，删除后右侧单元格左移
Range("B5").Delete Shift:=xlToLeft

删除B5单元格，删除后下方单元格上移
Range("B5").Delete Shift:=xlUp

删除B5单元格所在的行
Range("B5").EntireRow.Delete

删除B5单元格所在的列
Range("B5").EntireColumn.Delete

注意：如果不使用参数，将删除单元格的代码直接写为：
Range("B5").Delete
执行代码删除单元格后，将把下方单元格上移，功能等同于代码：
Range("B5").Delete Shift:=xlUp

4.6 项目示例
4.6.1 根据需求创建工作簿

Sub WbAdd()
    '程序创建"员工花名册.xlsx"工作簿，保存到本文件所在的目录中。
    Dim Wb As Workbook, sht As Worksheet
    Set Wb = Workbooks.Add                      '新建一个工作簿，并将其赋给变量Wb
    Set sht = Wb.Worksheets(1)
    With sht
        .Name = "花名册"                          '修改第一张工作表的标签名称
        '设置表头
        .Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "参加工作时间", "备注")
    End With
    Wb.SaveAs ThisWorkbook.Path & "\员工花名册.xlsx"    '保存新建的工作簿到指定目录中
    ActiveWorkbook.Close                                    '关闭新建的工作簿
End Sub

4.6.2 判断某个工作簿是否已经打开
打开的工作簿很多，要判断名为“成绩表.xlsx”的工作簿是否已经打开，程序可以这样写：
Sub IsOpen()
    '判断名称为“成绩表.xlsx”的工作薄文件是否已经打开。
    Dim i As Integer
    For i = 1 To Workbooks.Count
        If Workbooks(i).Name = "成绩表.xlsx" Then      '判断工作薄是否打开
            MsgBox "文件已打开！"
            Exit Sub                                   '如果找到该文件，退出过程
        End If
    Next
    MsgBox "文件没有打开！"
End Sub

例2
判断当前活动工作簿中是否存在标签名称为“一年级”的工作表。如果工作簿中没有这张工作表，就在所有工作表之前新建一张标签名称为“一年级”的工作表，如果工作表已存在，将其移动到所有工作表之前。
Sub ShtTest()
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Name = "一年级" Then
            sht.Move before := Worksheets(1)
            Exit Sub
        End If
    Next
    Worksheets.Add(before := Worksheets(1)).Name = "一年级"
End Sub

或

Sub ShtTest()
    On Error Resume Next
    If Worksheets("一年级") Is Nothing Then
        Worksheets.Add(before := Worksheets(1)).Name = "一年级"
    Else
        Worksheets("一年级").Move before := Worksheets(1)
    End If
End Sub

4.6.3 判断文件夹是否存在指定名称的工作簿文件

Sub TestFile()
    '判断指定目录中是否存在名为“员工花名册.xlsx”工作薄文件。
    Dim fil As String
    fil = ThisWorkbook.Path & "\员工花名册.xlsx"         '将要判断的文件名及路径保存到变量fil中
    If Len(Dir(fil)) > 0 Then                            '用Dir函数指定目录中的文件是否存在
        MsgBox "工作薄已存在!"
    Else
        MsgBox "工作薄不存在!"
    End If
End Sub

4.6.4 向未打开的工作簿中输入数据
一个Excel的工作簿文件，只有在打开的时候，才能在其中输入数据。如果想在一个未打开的工作簿中输入数据，可以利用VBA将文件打开，待输入完数据后，再将其保存并关闭。

Sub WbInput()
    '在当前文件所在目录中的“员工花名册.xlsx”工作簿中里添加一条记录!"
    Dim wb As String, xrow As Integer, arr
    wb = ThisWorkbook.Path & "\员工花名册.xlsx"           '指定输入数据的工作簿文件
    Workbooks.Open (wb)                                   '打开要输入数据的工作簿
    With ActiveWorkbook.Worksheets(1)                     '向工作簿里的第1张表里添加记录
        xrow = .Range("A1").CurrentRegion.Rows.Count + 1  '取得表格中第一条空行号
        '将需要增加的职工信息保存在数组arr里
        arr = Array(xrow - 1, "马军", "男", #7/8/1987#, #9/1/2010#, "10年新招")  '将要录入工作表的数据保存在数组中
        .Cells(xrow, 1).Resize(1, 6) = arr                '将数组写入单元格区域
    End With
    ActiveWorkbook.Close savechanges:=True                '关闭工作薄，并保存修改
End Sub

如果文件夹中有“员工花名册.xlsx”这个工作簿文件，执行这个程序后，Excel就会自动在原表格的后面增加一条记录。

4.6.5 隐藏活动工作表外的所有工作表
可以通过设置工作表的Visible属性隐藏或取消隐藏指定的工作表。

Sub ShtVisible()
    '隐藏活动工作表外的所有工作表
    Dim sht As Worksheet
    For Each sht In Worksheets                       '循环处理Worksheets集合中的每个对象
        If sht.Name <> ActiveSheet.Name Then
            sht.Visible = xlSheetVeryHidden          '深度隐藏工作表
        End If
    Next
End Sub

例2 将工作簿中所有的工作表都取消隐藏
Sub ShowAllSheets()
    Dim sht As Worksheet
    For Each sht In Worksheets
        sht.Visible = True
    Next
End Sub

4.6.6 批量新建指定名称的工作表

Sub ShtAdd()
    '以"数据"工作表A列中的信息来新建不同名称的工作表
    Dim i As Integer, sht As Worksheet
    i = 2                                  '保存第1个工作表名称的单元格在第2行
    Set sht = Worksheets("数据")            '将保存工作表名称的工作表赋给变量sht
    Do While sht.Cells(i, "A") <> ""           '直到A列的单元格为空时退出循环
        Worksheets.Add after:=Worksheets(Worksheets.Count)     '在所有工作表后插入新工作表
        ActiveSheet.Name = sht.Cells(i, "A").Value                '更改工作表的标签名称
        i = i + 1                           '行号增加1
    Loop
End Sub

例2 用前面的程序新建工作表，要求在“数据”工作表A列中保存的工作表名称不存在重复数据，否则会因为Excel不能在同一个工作簿中插入两张同名工作表而导致程序执行出错。
Excel不允许在同一工作簿中插入多张同名的工作表，但是预先并不确定“数据”工作表A列中是否存在相同的数据，为了避免程序在执行过程中出错，我们希望在遇到相同的数据时，只插入一张该名称的工作表。

Sub ShtAdd()
        Dim i As Integer, sht As Worksheet
        i = 2
        Set sht = Worksheets("成绩表")
          '定义循环条件
        Do While sht.Cells(i, "C").Value <> ""       
         '当没有对应班级工作表时，忽略下一行代码引起的运行时错误 
       On Error Resume Next  
       '判断工作表否存在
            If Worksheets(sht.Cells(i, "C").Value) Is Nothing Then   
                     Worksheets.Add after:=Worksheets(Worksheets.Count)
                     ActiveSheet.Name = sht.Cells(i, "C").Value
            End If
        i = i + 1
        Loop
End Sub

4.6.7 批量对数据分类，并保存到不同的工作表中
在一张成绩表中，保存着同一年级多个班级的成绩记录，现要根据所属班级对成绩记录进行分类，并保存到与成绩表结构相同(已有表头)，以班级名称命名的工作表中。

Sub FenLei()
    '将成绩表按班级分类并保存到各工作表中
    Dim i As Long, bj As String, rng As Range
    i = 2                    '成绩表中要处理的第1条记录在第2行
    bj = Worksheets("成绩表").Cells(i, "C").Value
    Do While bj <> ""        '直到成绩表中的C列的单元格为空单元格时终止循环
        '确定班级工作表中A列的第1个空单元格，作为粘贴成绩记录的目标区域
        Set rng = Worksheets(bj).Range("A1048576").End(xlUp).Offset(1, 0)
        Worksheets("成绩表").Cells(i, "A").Resize(1, 7).Copy rng     '将成绩表中的记录复制到相应的工作表中
        i = i + 1             '行号加1,以便下次循环时能处理下一条成绩记录
        bj = Worksheets("成绩表").Cells(i, "C").Value
    Loop
End Sub

例2 如果工作簿中的班级工作表中原来已经有数据记录，执行程序前，要将原有的记录清除。

Sub 清除原表数据()
    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Name <> "成绩表" Then
          sht.Range("A2:G1048576").ClearContents
        End If
    Next
End Sub

4.6.8 将多张工作表中的数据合并到一张工作表中

Sub hebing()
    '把各班成绩表中的记录合并到"成绩表"工作表中
    Dim sht As Worksheet
    Set sht = Worksheets("成绩表")
    sht.Rows("2:65536").Clear      '删除成绩表中的原有记录
    Dim wt As Worksheet, xrow As Integer, rng As Range
    For Each wt In Worksheets                   '循环处理工作簿中的每张工作表
        If wt.Name <> "成绩表" Then
            Set rng = sht.Range("A1048576").End(xlUp).Offset(1, 0)
            xrow = wt.Range("A1").CurrentRegion.Rows.Count - 1
            wt.Range("A2").Resize(xrow, 7).Copy rng
        End If
    Next
End Sub

4.6.9 将工作簿中的每张工作表都保存为单独的工作簿文件

Sub SaveToFile()
     '把各个班级的成绩表保存在指定的文件夹中
    Application.ScreenUpdating = False                       '关闭屏幕更新
    Dim folder As String
    folder = ThisWorkbook.Path & "\班级成绩表"               '保存工作簿文件的目录
    If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder   '选择是否新建该文件夹
    Dim sht As Worksheet
    For Each sht In Worksheets
        sht.Copy                                   '复制工作表到新工作簿
        ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"  '保存工作簿，并命名
        ActiveWorkbook.Close
    Next
    Application.ScreenUpdating = True                           '开启屏幕更新
End Sub

注意：使用MkDir新建文件夹，变量folder是新建的文件夹的名称及所在目录。

4.6.10 将工作簿中的数据合并到同一张工作表中

Sub HzWb()
    Dim bt As Range, r As Long, c As Long
    r = 1    '1 是表头的行数
    c = 7    '7 是表头的列数
    Dim wt As Worksheet
    Set wt = ThisWorkbook.Worksheets(1)    '将汇总表赋给变量wt
    wt.Rows(r + 1 & ":1048576").ClearContents  ' 清除汇总表中原表数据,只保留表头
    Application.ScreenUpdating = False
    Dim FileName As String, sht As Worksheet, wb As Workbook
    Dim Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    '这是要汇总的工作簿文件的扩展名，只有扩展名为“xlsx”的工作簿中的记录才会被汇总。
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then        ' 判断文件是否是汇总数据的工作簿
            Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1     ' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName     '将第1个要汇总的工作簿名称赋给变量fn
            Set wb = GetObject(fn)        ' 将变量fn 代表的工作簿对象赋给变量wb
            Set sht = wb.Worksheets(1)    ' 将要汇总的工作表赋给变量sht
            ' 将工作表中要汇总的记录保存在数组arr里
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5))
            ' 将数组arr 中的数据写入工作表
            wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            wb.Close False
        End If
        FileName = Dir    ' 用Dir 函数取得其他文件名，并赋给变量
    Loop
    Application.ScreenUpdating = True
End Sub

4.6.11 为同一工作簿中的工作表建一个带链接的目录
Sub mulu()
    '为工作簿中所有工作表建立目录!
    Dim wt As Worksheet
    Set wt = Worksheets("工作表目录")
    wt.Rows("2:1048576").ClearContents                  '清除工作表中原有数据
    Dim sht As Worksheet, irow As Integer
    irow = 2
    For Each sht In Worksheets
        wt.Cells(irow, "A").Value = irow - 1            '写入序号
        '写入工作表名，并建立超链接
        wt.Hyperlinks.Add Anchor:=wt.Cells(irow, "B"), Address:="", _
             SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
        irow = irow + 1      '行号加1
    Next
End Sub

问题：
如果工作簿中已有设置好表头，且名称为“工作表目录”的工作表，执行前面的程序后就能完成制作目录的操作，反之，执行程序就会出错。
如果想在工作簿中没有名称为“工作表目录”的工作表时，让程序自动新建这张工作表后，再在其中制作目录，以避免程序在执行过程中出现错误，你知道应该怎样修改本例的程序吗？

Sub 为所有工作表制作目录()
    Dim sht As Worksheet
    Dim wt As Worksheet
    Dim irow As Integer
    On Error Resume Next
    Set wt = Worksheets("工作表目录")
    '如果目录工作表不存在，则新建工作表
    If wt Is Nothing Then
         Worksheets.Add before:=Worksheets(1)
         ActiveSheet.Name = "工作表目录"
         Set wt = Worksheets("工作表目录")
    End If
    On Error GoTo 0
    '设置目录工作表的表头
    With wt
        .Cells.ClearContents
        .Range("A1:B1").Value = Array("序号", "工作表名称")
    End With
    '为工作簿中所有工作表建立目录
    irow = 2
    For Each sht In Worksheets
        '写入序号
        wt.Cells(irow, "A").Value = irow - 1
        '写入工作表名，并建立超链接
        wt.Hyperlinks.Add Anchor:=wt.Cells(irow, "B"), Address:="", _
             SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
        irow = irow + 1
    Next
End Sub