|
本帖最后由 冰心8549 于 2011-11-15 13:06 编辑
快速VBA目录
快速VBA目录请求各位,能不能帮忙自动加序号?
Sub mulu()
On Error GoTo R '如遇到错误语句将直接挑到R运行
Dim i As Integer '定义I,shtcount和SelectionCell变量
Dim ShtCount As Integer
Dim SelectionCell As Range
ShtCount = Worksheets.Count
If ShtCount = 0 Or ShtCount = 1 Then Exit Sub '工作簿内仅0或1张工作表时候退出
Application.ScreenUpdating = False '取消刷新屏幕以便加快运行代码
For i = 1 To ShtCount '遍历所有工作表
If Sheets(i).Name = "目录" Then '当第一张工作表名为"目录"时候,将该表置前
Sheets("目录").Move Before:=Sheets(1)
End If
Next i
If Sheets(1).Name <> "目录" Then '当第一张工作表名不为"目录"时候.生成"目录"
ShtCount = ShtCount + 1
Sheets(1).Select
Sheets.Add
Sheets(1).Name = "目录"
End If
Sheets("目录").Select '选定工作表"目录"
Columns("B:B").Delete Shift:=xlToLeft '清除B列
Application.StatusBar = "正在生成目录…………请等待!" '添加等待状态条
For i = 2 To ShtCount '遍历除第一张工作表外所有工作表,建立链接
ActiveSheet.Hyperlinks.Add Anchor:=Worksheets("目录").Cells(i, 2), Address:="", SubAddress:= _
"'" & Sheets(i).Name & "'!R1C1", TextToDisplay:=Sheets(i).Name
Next
Sheets("目录").Select
Columns("B:B").AutoFit '自动调整
Cells(1, 2) = "目录" 'B列第一个单元格录"目录"
Set SelectionCell = Worksheets("目录").Range("B1")
With SelectionCell '调整单元格格式
.HorizontalAlignment = xlDistributed
.VerticalAlignment = xlCenter
.AddIndent = True
.Font.Bold = True
.Interior.ColorIndex = 34
End With
Application.StatusBar = False
Application.ScreenUpdating = True
R:
End Sub
要求:效果
要求:效果2 |
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有帐号?注册
x
|