|
严重建议不要勾选,勾选之后会把目标工作表的B1单元格清空,还没发撤销,非常坑爹。提过这个问题,但是版本很久没更新了。我自己写了一段代码,比较笨的办法,基本上都是从录制宏里扒出来的,用的最基本的语句。放在了模板文件里,在自定义功能区创建了按钮,关联到这段代码。
Sub IndexAllSheets()
'建立所有工作表的索引,并在各工作表B1单元格建立返回索引页的链接
On Error GoTo msg '如果已有名为“索引”的工作表,将弹出通知要求修改
Sheets.Add.Name = "索引"
Cells(1, 1) = "次序"
Cells(1, 2) = "工作表链接"
Cells(1, 3) = "是否隐藏"
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
If Sheets("索引").Index > 1 Then
If Sheets(1).Visible = False Then
Sheets(1).Visible = True
Sheets("索引").Move before:=Sheets(1)
Sheets(2).Visible = False
Else
Sheets("索引").Move before:=Sheets(1)
End If '将索引工作表挪到第一个工作表之前,如果第一个工作表被隐藏,需要先将其设为可见再恢复隐藏
End If
For i = 2 To Sheets.Count
Sheets("索引").Cells(i, 1) = i
Sheets("索引").Cells(i, 2) = Sheets(i).Name
If Sheets(i).Visible = False Then '由于需要激活目标工作表以便寻找第一个可见单元格,所以需要临时将被隐藏的工作表恢复可见
Sheets("索引").Cells(i, 3) = "已隐藏"
Sheets("索引").Hyperlinks.Add anchor:=Sheets("索引").Cells(i, 2), Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1"
Sheets(i).Visible = True
Sheets(i).Activate
Cells(1, 1).End(xlToRight).End(xlToLeft).End(xlDown).End(xlUp).Select '选定第一个可见单元格
If WorksheetFunction.CountA(Selection) = 0 Then
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:="索引!B" & i, TextToDisplay:="返回索引"
Else
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:="索引!B" & i, ScreenTip:="返回索引"
End If
Sheets(i).Visible = False
Else
Sheets("索引").Hyperlinks.Add anchor:=Sheets("索引").Cells(i, 2), Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1"
Sheets(i).Activate
Cells(1, 1).End(xlToRight).End(xlToLeft).End(xlDown).End(xlUp).Select
If WorksheetFunction.CountA(Selection) = 0 Then
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:="索引!B" & i, TextToDisplay:="返回索引"
Else
ActiveSheet.Hyperlinks.Add anchor:=Selection, Address:="", SubAddress:="索引!B" & i, ScreenTip:="返回索引"
End If
End If
Next i
Sheets("索引").Activate
Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Font
.Name = "Calibri Light"
.Size = 12
End With
Cells(1, 1).Select
Columns("A:C").EntireColumn.AutoFit
Windows("Book.xltm").Close
Exit Sub
msg:
MsgBox ("工作簿中已存在名为“索引”的工作表,请将其修改为其他名称后再重新建立索引。")
Application.DisplayAlerts = False 'Excel会先增加一个以codename命名的工作表再重命名,重命名为“索引”时如果重名需要先将该空工作表删除
If IsEmpty(ActiveSheet.UsedRange) Then ActiveSheet.Delete
Windows("Book.xltm").Close
Application.DisplayAlerts = True
End Sub |
|