学步园

7.1 设置阶段

代码清单7.1：使用Parent属性获得一个对象的父对象的指针

 

'使用Parent属性获得一个对象的父对象的指针
Sub MeetMySingleParent()
    'Declare a worksheet variable named ws
    Dim ws As Worksheet
    
    'set ws to refer to sheet 1
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    'please meet my parent - Mrs. Workbook
    Debug.Print ws.Parent.Name
    
    Set ws = Nothing
    
End Sub

 

以编程方式区分出代码名称和实际名称

 

'prints out name & code name
'assumes a worksheet has been named
'in the vbe as: wsMenu

Dim wsMenu As Worksheet ' = ThisWorkbook.Worksheets(1)
Sub WhatsMyName()
    On Error Resume Next
    
    Debug.Print "The name on my worksheet tab is " & wsMenu.Name & ", " & vbCrLf
    Debug.Print "But you can call me " & wsMenu.CodeName
    
End Sub

 

 

7.2 在使用工作表之前确认它们

代码清单7.2：确认一个工作表名称在使用其之前已存在

 

'代码清单7.2：确认一个工作表名称在使用其之前已存在
Function WorksheetExists(wb As Workbook, sName As String) As Boolean
    Dim s As String
    On Error GoTo bWorksheetExistsErr
    s = wb.Worksheets(sName).Name
    WorksheetExists = True
    Exit Function
bWorksheetExistsErr:
    WorksheetExists = False
    
End Function

 

 

代码清单7.3：使用函数检查代码名称的存在性

 

'代码清单7.3：使用函数检查代码名称的存在性

'determines if a given worksheet name exists in a workbook
'checks by looking for the code name rather than the name
Function WorksheetCodenameExists(wb As Workbook, sCodename As String) As Boolean
    Dim s As String
    Dim ws As Worksheet
    
    WorksheetCodenameExists = False
    For Each ws In wb.Worksheets
        If StrComp(ws.CodeName, sCodename, vbTextCompare) = 0 Then
        WorksheetCodenameExists = True
        End If
    Next
    
    Set ws = Nothing
End Function

 

 

7.3 隐藏与取消隐藏

代码清单7.4：隐藏和取消隐藏工作表

 

'代码清单7.4: 隐藏和取消隐藏工作表
'/Hides the worksheet named sName
Sub HideWorksheet(sName As String, bVeryHidden As Boolean)
    If WorksheetExists(ThisWorkbook, sName) Then
        If bVeryHidden Then
            ThisWorkbook.Worksheets(sName).Visible = xlSheetVeryHidden
        Else
            ThisWorkbook.Worksheets(sName).Visible = xlSheetHidden
        End If
    End If
End Sub
Sub UnhideWorksheet(sName As String)
    If WorksheetExists(ThisWorkbook, sName) Then
        ThisWorkbook.Worksheets(sName).Visible = xlSheetVisible
    End If
End Sub
Sub UsingHideUnhide()
    Dim lResponse As Long
    
    'Hide the worksheet
    HideWorksheet "Sheet2", True
    
    'Show that it is hidden - ask to unhide
    lResponse = MsgBox("the worksheet is very hidden. unhide?", vbYesNo)
    
    If lResponse = vbYes Then
        UnhideWorksheet "Sheet2"
    End If    
End Sub

 

 

代码清单7.5：取消隐藏工作薄中的每一个工作表

 

'代码清单7.5: 取消隐藏工作薄中的每一个工作表
'Unhides all worksheets in the workbook, even very hidden worksheets
Sub UnhideAllWorksheets()
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws
    Set ws = Nothing
    
End Sub

 

 

7.4 锁住关键内容

代码清单7.6：利用Protect方法保护工作表

 

'代码清单7.6: 利用Protect方法保护工作表
Function ProtectWorksheet(ws As Worksheet, sPassword As String) As Boolean
    On Error GoTo ErrHandler
    If Not ws.ProtectContents Then
        ws.Protect sPassword, True, True, True
    End If
    
    ProtectWorksheet = True
    Exit Function
ErrHandler:
    ProtectWorksheet = False
End Function

 

 

代码清单7.7：利用Unprotect方法解除工作表保护

 

'代码清单7.7: 利用Unprotect方法解除工作表保护
Function UnprotectWorksheet(ws As Worksheet, sPassword As String) As Boolean
    On Error GoTo ErrHandler
    If ws.ProtectContents Then
        ws.Unprotect sPassword
    End If
    UnprotectWorksheet = True
    
    Exit Function
ErrHandler:
    UnprotectWorksheet = False    
End Function
Sub TestProtection()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    'example of how you might use protectworksheet
    If Not ProtectWorksheet(ws, "TestPassword") Then
        Debug.Print "the worksheet could not be protected."
    Else
        Debug.Print "the worksheet has been protected."
    End If
    'example of how you might use unprotect worksheet
    If UnprotectWorksheet(ws, "testpassword") Then
        'unprotected - safe to modify the worksheet
        'contents pogrammatically now...
        Debug.Print "the worksheet has been unprotected."
    Else
        Debug.Print "the worksheet could not be unprotected."
    End If
    
    Set ws = Nothing
End Sub

 

 

7.5 管理工作薄工作表

7.5.1 增加和删除工作表

代码清单7.8：使用DeleteSheet函数安全删除工作表

 

'代码清单7.8: 使用DeleteSheet函数安全删除工作表
'Deletes the worksheet given in the ws parameter
'if bQuiet then do not display Excel alerts
Function DeleteSheet(ws As Worksheet, bQuiet As Boolean) As Boolean
    Dim bDeleted As Boolean
    On Error GoTo ErrHandler
    bDeleted = False
    
    If CountVisibleSheets(ws.Parent) > 1 Then
        'ok to delete - display alerts?
        If bQuiet Then Application.DisplayAlerts = False
        'finally! delete the darn thing
        bDeleted = ws.Parent.Worksheets(ws.Name).Delete
    Else
        'forget it - need at least
        'one visible sheet in a
        'workbook, bDeleted is
        'already false
    End If
    
ExitPoint:
    'make sure display alerts is always on
    Application.DisplayAlerts = True
    DeleteSheet = bDeleted
    Exit Function
ErrHandler:
    bDeleted = False
    Resume ExitPoint
End Function
'returns a count of all of the visible sheets
'in the workbook wb
Function CountVisibleSheets(wb As Workbook) As Integer
    Dim nSheetIndex As Integer
    Dim nCount As Integer
    nCount = 0
    For nSheetIndex = 1 To wb.Sheets.Count
        If wb.Sheets(nSheetIndex).Visible = xlSheetVisible Then
            nCount = nCount + 1
        End If
    Next
    CountVisibleSheets = nCount        
End Function

 

 

7.5.2 移动和复制工作表

代码清单7.9：在工作薄中按字母顺序排序工作表

 

'代码清单7.9: 在工作薄中按字母顺序排序工作表
'performs a simple bubble sort to
'sort the worksheets in the workbook

Sub AlphabetizeWorksheets(wb As Workbook)
    Dim bSorted As Boolean
    Dim nSheetsSorted As Integer
    Dim nSheets As Integer
    Dim n As Integer
    
    nSheets = wb.Worksheets.Count
    nSheetsSorted = 0
    
    Do While (nSheetsSorted < nSheets) And Not bSorted
        bSorted = True
        nSheetsSorted = nSheetsSorted + 1
        For n = 1 To nSheets - nSheetsSorted
            If StrComp(wb.Worksheets(n).Name, wb.Worksheets(n + 1).Name, vbTextCompare) > 0 Then
                'out of order - swap the sheets
                wb.Worksheets(n + 1).Move beforfore:=wb.Worksheets(n)
                bSorted = False
            End If
        Next
    Loop
End Sub

 

 

7.6 说明工作表事件

代码清单7.10：使用Change事件响应工作表改变

在选择响应的事件之前，确认在工程浏览器中选择了适当的工作表

 

'代码清单7.10：使用Change事件响应工作表改变
Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address
        Case "$B$1"
            ChangeColumnWidth Target.Value
        Case "$B$2"
            ChangeRowHeight Target.Value
    End Select
End Sub
Sub ChangeColumnWidth(Width As Variant)
    If IsNumeric(Width) Then
        If Width > 0 And Width < 100 Then
        Me.Columns.ColumnWidth = Width
        ElseIf Width = 0 Then
        Me.Columns.ColumnWidth = Me.StandardWidth
        End If
    End If
End Sub
Sub ChangeRowHeight(Height As Variant)
    If IsNumeric(Height) Then
        If Height > 0 And Height < 100 Then
            Me.Rows.RowHeight = Height
        ElseIf Height = 0 Then
            Me.Rows.RowHeight = Me.StandardHeight
        End If
    End If
    
End Sub