Excel VBA 共五章学习实例(第1、2、6、7、9章)实用VBA源代码(4)

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

百度搜索“77cn”或“免费范文网”即可找到本站免费阅读全部范文。收藏本站方便下次阅读，免费范文网，提供经典小说综合文库Excel VBA 共五章学习实例(第1、2、6、7、9章)实用VBA源代码(4)在线全文阅读。