Excel VBA‎ > ‎

Worksheets in VBA

Introduction


Excel has the ability to manage it's worksheet as part of a collection. The parent to that collection is the workbook.
This page describes some VBA procedure that you can use to operate on multiple worksheet in a workbook. These functions assume different values for password or that they are visible

Hide all sheet, assuming there is no protection on them


Sub hideallsheet()
    Dim mysheet As Worksheet
    For Each mysheet In ThisWorkbook.Worksheets

        mysheet.Visible = xlSheetHidden
    Next
End Sub

 Unprotect all sheets, assuming they have no password. If a password exists, an argument needs to be added to the unprotect part of the code

Sub unprotectall()
    Dim myboolean As Boolean
    Dim mysheet As Worksheet

    myboolean = Application.ScreenUpdating
    Application.ScreenUpdating = False
    For Each mysheet In Worksheets
        unprotect mysheet
    Next
    Application.ScreenUpdating = myboolean

End Sub

Unprotect a specific sheet, with optional password


Sub unprotect(mysheet As Worksheet, Optional mypassword As String)
    On Error Resume Next
    mysheet.unprotect mypassword
    On Error GoTo 0

End Sub

Protect a specific heet, with optional password


Sub protectallsheet()
    Dim mysheet As Worksheet

    For Each mysheet In Worksheets
        Protectsheet mysheet
    Next

End Sub

Protect one specific sheet, with a password that is optional


Sub Protectsheet(mysheet As Worksheet, Optional mypassword As String)
    With mysheet


        .Protect "prsq", DrawingObjects:=True, Contents:=True, Scenarios:=True _
               , AllowFiltering:=True, AllowUsingPivotTables:=True

    End With

End Sub


'Needed to reduce the file size. Modified slightly from the microsoft version to unprotect all sheets


Sub ClearExcessRowsAndColumns()

    Dim ar As Range, r As Double, c As Double, tr As Double, tc As Double
    Dim wksWks As Worksheet, ur As Range, i As Integer
    Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
    Dim shp As Shape
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    unProtectAllSheets
    On Error Resume Next
    For Each wksWks In ActiveWorkbook.Worksheets
        Err.Clear
        'Store worksheet protection settings and unprotect if protected.
        blProtCont = wksWks.ProtectContents
        blProtDO = wksWks.ProtectDrawingObjects
        blProtScen = wksWks.ProtectScenarios
        wksWks.unprotect ""
        If Err.Number = 1004 Then
            Err.Clear
            MsgBox "'" & wksWks.Name & _
                   "' is protected with a password and cannot be checked." _
                 , vbInformation
        Else

            r = 0
            c = 0

            'Determine if the sheet contains both formulas and constants
            Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
                           wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
            'If both fails, try constants only
            If Err.Number = 1004 Then
                Err.Clear
                Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
            End If
            'If constants fails then set it to formulas
            If Err.Number = 1004 Then
                Err.Clear
                Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
            End If
            'If there is still an error then the worksheet is empty
            If Err.Number <> 0 Then
                Err.Clear
                If wksWks.UsedRange.Address <> "$A$1" Then
                    ur.EntireRow.Delete
                Else
                    Set ur = Nothing
                End If
            End If
            'On Error GoTo 0
            If Not ur Is Nothing Then
                'determine the last column and row that contains data or formula
                For Each ar In ur.Areas
                    i = i + 1
                    tr = ar.Range("A1").Row + ar.Rows.Count - 1
                    tc = ar.Range("A1").Column + ar.Columns.Count - 1
                    If tc > c Then c = tc
                    If tr > r Then r = tr
                Next
                'Determine the area covered by shapes
                'so we don't remove shading behind shapes
                For Each shp In wksWks.Shapes
                    tr = shp.BottomRightCell.Row
                    tc = shp.BottomRightCell.Column
                    If tc > c Then c = tc
                    If tr > r Then r = tr
                Next

                Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count)
                ur.Clear
                'Reset row height which can also cause the lastcell to be innacurate
                ur.EntireRow.RowHeight = _
                wksWks.StandardHeight
                Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
                                      wksWks.Cells(1, 256)).EntireColumn
                'Reset column width which can also cause the lastcell to be innacurate
                ur.EntireColumn.ColumnWidth = _
                wksWks.StandardWidth
            End If
        End If
        'Reset protection.
        wksWks.Protect "", blProtDO, blProtCont, blProtScen
        Err.Clear
    Next
    ActiveWorkbook.Save
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub