Sub 建立目录()
Dim i As Byte
On Error Resume Next
Application.ScreenUpdating = False
Dim XStr, YStr, ZStr
XStr = " -"
ZStr = ""
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "目录" Then
Exit For
End If
Next
If i > Worksheets.Count Then Sheets.Add.Name = "目录"
Sheets("目录").Move before:=Sheets(1)
Sheets("目录").Select
Range("A:B").Clear
Range("B:B").NumberFormatLocal = "@"
Worksheets(1).Cells(1, 1).Value = "编号"
Worksheets(1).Cells(1, 2).Value = "目录"
For i = 2 To Worksheets.Count
Worksheets(1).Cells(i, 1).Value = i - 1
Worksheets(1).Cells(i, 2).Value = Worksheets(i).Name
For j = 1 To Len(Worksheets(i).Name)
YStr = Mid(Worksheets(i).Name, j, 1)
If InStr(XStr, YStr) <> 0 Then
ZStr = "'"
Exit For
End If
Next
ActiveSheet.Hyperlinks.Add Anchor:=Worksheets(1).Cells(i, 2), Address:="", SubAddress:=ZStr & Worksheets(i).Name & ZStr & "!A1", TextToDisplay:=Worksheets(i).Name
Next
Columns("A:A").HorizontalAlignment = xlCenter
Columns("A:A").VerticalAlignment = xlCenter
Columns("B:B").HorizontalAlignment = xlLeft
Columns("B:").VerticalAlignment = xlLeft
Range("d2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
Dim i As Byte
On Error Resume Next
Application.ScreenUpdating = False
Dim XStr, YStr, ZStr
XStr = " -"
ZStr = ""
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "目录" Then
Exit For
End If
Next
If i > Worksheets.Count Then Sheets.Add.Name = "目录"
Sheets("目录").Move before:=Sheets(1)
Sheets("目录").Select
Range("A:B").Clear
Range("B:B").NumberFormatLocal = "@"
Worksheets(1).Cells(1, 1).Value = "编号"
Worksheets(1).Cells(1, 2).Value = "目录"
For i = 2 To Worksheets.Count
Worksheets(1).Cells(i, 1).Value = i - 1
Worksheets(1).Cells(i, 2).Value = Worksheets(i).Name
For j = 1 To Len(Worksheets(i).Name)
YStr = Mid(Worksheets(i).Name, j, 1)
If InStr(XStr, YStr) <> 0 Then
ZStr = "'"
Exit For
End If
Next
ActiveSheet.Hyperlinks.Add Anchor:=Worksheets(1).Cells(i, 2), Address:="", SubAddress:=ZStr & Worksheets(i).Name & ZStr & "!A1", TextToDisplay:=Worksheets(i).Name
Next
Columns("A:A").HorizontalAlignment = xlCenter
Columns("A:A").VerticalAlignment = xlCenter
Columns("B:B").HorizontalAlignment = xlLeft
Columns("B:").VerticalAlignment = xlLeft
Range("d2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
End Sub
原始地址 http://club.excelhome.net/thread-1243181-1-1.html