|
回复 骑猪返北流 的帖子
在工作簿中新建一个工作表,将以下代码粘贴到工作表VBE窗口中,随便选择2个及以上单元格,按删除键,即可
- Private Sub Worksheet_Activate()
- On Error Resume Next
- Dim i As Integer, shme As String
- shme = ActiveSheet.Name
- For i = 1 To Sheets.Count
- If Sheets(i).Name <> shme Then Sheets(i).Visible = 2
- Next
- End Sub
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim i As Byte
- If Target.Count > 1 And Target.Text = "" Then
- If MsgBox(vbCrLf & "注意:" & vbCrLf + vbCrLf & "选择“是”将清除当前工作表数据,更新工作表目录;" & vbCrLf + vbCrLf & "选择“否”不执行程序。", vbYesNo + vbQuestion + vbDefaultButton1, "注意:是否重新建立目录工作表!!!") <> 6 Then Exit Sub
- With Application
- .DisplayAlerts = False '打开对话框提示
- .EnableEvents = False '启用事件
- .ScreenUpdating = False '打开屏幕更新
- End With
- With ActiveSheet
- .Cells.Clear
- .Name = "目录"
- .Cells(1).Value = "工作表名称列表"
- .Cells(1).HorizontalAlignment = xlCenter '水平居中
- .Cells(2, 1).Value = "目录"
- For i = 2 To Sheets.Count
- .Cells(i + 1, 1).Value = Sheets(i).Name
- Next
- .Columns(1).AutoFit
- .Cells(1).CurrentRegion.NumberFormatLocal = " @"
- End With
- With Application
- .DisplayAlerts = True '打开对话框提示
- .EnableEvents = True '启用事件
- .ScreenUpdating = True '打开屏幕更新
- End With
- End If
- End Sub
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- On Error Resume Next
- If Target.Row > 2 And Target.Column = 1 And Target.Count = 1 Then
- Sheets(Target.Value).Visible = -1
- Sheets(Target.Value).Activate
- End If
- End Sub
复制代码
|
|