Application.DisplayAlerts = False For Each Sht In Worksheets
If Sht.Name Like \ Next
Application.DisplayAlerts = True Set Sht = Nothing End Sub
范例22 禁止删除指定工作表
Private Sub Workbook_Activate()
Application.CommandBars.FindControl(ID:=847).OnAction = \End Sub
Sub MyDelSht()
If ActiveSheet.CodeName = \
MsgBox ActiveSheet.Name & \工作表禁止删除!\ Else
ActiveSheet.Delete End If End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars.FindControl(ID:=847).OnAction = \End Sub
范例23 禁止更改工作表名称
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sheet1.Name <> \ ThisWorkbook.Save End Sub
范例24 判断是否存在指定工作表
Sub ShtExists()
Dim Sht As Worksheet On Error GoTo line
Set Sht = Worksheets(\
MsgBox \工作簿中已有\工作表!\ Exit Sub line:
MsgBox \工作簿中没有\工作表!\End Sub
16
范例25 工作表的深度隐藏
Public sht As Worksheet
Private Sub Workbook_BeforeClose(Cancel As Boolean) Sheet1.Visible = True
For Each sht In ThisWorkbook.Sheets If sht.CodeName <> \ sht.Visible = xlSheetVeryHidden End If Next
ThisWorkbook.Save End Sub
Private Sub Workbook_Open()
For Each sht In ThisWorkbook.Sheets If sht.CodeName <> \ sht.Visible = xlSheetVisible End If Next
Sheet1.Visible = xlSheetVeryHidden End Sub
范例26 工作表的保护与取消保护
在Sub ShProtect()
With Sheet1
.Unprotect Password:=\
.Cells(1, 1) = .Cells(1, 1) + 100 .Protect Password:=\ End With End Sub
Sub RemoveShProtect()
Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer Dim i7 As Integer, i8 As Integer, i9 As Integer Dim i10 As Integer, i11 As Integer, i12 As Integer Dim t As String
On Error Resume Next
If ActiveSheet.ProtectContents = False Then MsgBox \该工作表没有保护密码!\ Exit Sub End If t = Timer
For i1 = 65 To 66: For i2 = 65 To 66: For i3 = 65 To 66 For i4 = 65 To 66: For i5 = 65 To 66: For i6 = 65 To 66 For i7 = 65 To 66: For i8 = 65 To 66: For i9 = 65 To 66
17
For i10 = 65 To 66: For i11 = 65 To 66: For i12 = 32 To 126
ActiveSheet.Unprotect Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) _ & Chr(i6) & Chr(i7) & Chr(i8) & Chr(i9) & Chr(i10) & Chr(i11) & Chr(i12) If ActiveSheet.ProtectContents = False Then
MsgBox \解除工作表保护!用时\秒\ Exit Sub End If
Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub
范例27 自动建立工作表目录
Private Sub Worksheet_Activate() Dim Sht As Worksheet Dim a As Integer Dim r As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row a = 2
If r > 1 Then Range(\ For Each Sht In Worksheets
If Sht.CodeName <> \ Cells(a, 1).Value = Sht.Name a = a + 1 End If Next
Set Sht = Nothing End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim r As Integer
r = Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next
If Not Application.Intersect(Target, Range(\ Sheets(Target.Text).Select End If End Sub
范例28 循环选择工作表
如果需要循环选择工作簿中的工作表，可以使用Worksheet对象的Next属性和Previous属性，范例代码如下：
Sub ShtNext()
If ActiveSheet.Index < Worksheets.Count Then ActiveSheet.Next.Activate Else
Worksheets(1).Activate
18
End If End Sub
Sub ShtPrevious()
If ActiveSheet.Index > 1 Then ActiveSheet.Previous.Activate Else
Worksheets(Worksheets.Count).Activate End If End Sub
范例29 工作表中一次插入多行
Sub InSertRow()
Dim i As Integer For i = 1 To 3
Sheet1.Rows(3).Insert Next End Sub
范例30 删除工作表中的空行
Sub DelBlankRow() Dim r As Long Dim i As Long
r = Sheet1.UsedRange.Rows.Count For i = r To 1 Step -1
If Rows(i).Find(\ Rows(i).Delete End If Next End Sub
范例31 删除工作表的重复行
Sub DeleteRow()
Dim r As Integer Dim i As Integer With Sheet1
r = .Cells(.Rows.Count, 1).End(xlUp).Row For i = r To 1 Step -1
If WorksheetFunction.CountIf(.Columns(1), .Cells(i, 1)) > 1 Then .Rows(i).Delete End If Next End With
19
End Sub
范例32 定位删除特定内容所在的行
Sub SpecialDelete() Dim r As Long With Sheet1
r = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(\ .Columns(1).SpecialCells(4).EntireRow.Delete End With End Sub
范例33 判断是否选中整行
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Rows.Count = 1 Then
If Target.Columns.Count = 16384 Then
MsgBox \您选中了整行,当前行号\ End If End If End Sub
范例34 限制工作表的滚动区域
Private Sub Workbook_Open()
Sheet1.ScrollArea = \End Sub
范例35 复制自动筛选后的数据区域
Sub CopyFilter()
Sheet2.Cells.Clear With Sheet1
If .FilterMode Then
.AutoFilter.Range.SpecialCells(12).Copy Sheet2.Cells(1, 1) End If End With End Sub
20