VBA/Excel/Access/Word/Excel/Worksheet Protection

Add protection to Worksheet

 
Sub Set_Protection()
    On Error GoTo errorHandler
    Dim myDoc As Worksheet
    Dim cel As Range
    Set myDoc = ActiveSheet
    myDoc.Unprotect
    For Each cel In myDoc.UsedRange
        cel.Locked = True
        cel.Font.ColorIndex = xlColorIndexAutomatic
    Next
    myDoc.Protect
    Exit Sub
    errorHandler:
    MsgBox Error
End Sub

Add user edit range

 
Sub AddUserEditRange()
    Dim ws As Worksheet, aer As AllowEditRange
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Unprotect "Excel2003"
    Set aer = ws.Protection.AllowEditRanges.Add("User Range", ws.Range("A1:D4"))
    aer.Users.Add "Power Users", True
    ws.Protect "Excel2003"
End Sub

Formulas Protection

 
Sub ProtectFormulas()
    Dim ws As Worksheet, rng As Range
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Unprotect
    " Get each used cell in the worksheet.
    For Each rng In ws.UsedRange
        " If it contains a formula, lock the cell.
        If InStr(rng.Formula, "=") Then
            rng.Locked = True
        " Otherwise unlock the cell.
        Else
            rng.Locked = False
        End If
    Next
    ws.Protect "Excel2003"
End Sub

Protecting Worksheet Assets with the Protect Method

 
Sub TestProtection() 
    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Worksheets(1) 
    If Not ProtectWorksheet(ws, "TestPassword") Then 
        Debug.Print "The worksheet could not be protected." 
    Else 
        Debug.Print "The worksheet has been protected." 
    End If 
    If UnprotectWorksheet(ws, "TestPassword") Then 
        Debug.Print "The worksheet has been unprotected." 
    Else 
        Debug.Print "The worksheet could not be unprotected." 
    End If 
    Set ws = Nothing 
End Sub 
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 
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

Protect Sheet

 
Sub ProtectSheet()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Protect "Excel2003", , True, , True
    ws.Range("A1").Value = 42
    Debug.Print ws.ProtectContents
    Debug.Print ws.ProtectDrawingObjects
    Debug.Print ws.ProtectionMode
    Debug.Print ws.ProtectScenarios
End Sub

remove user

 
Sub RemoveUser()
    Dim ws As Worksheet, rng As Range, aer As AllowEditRange
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Unprotect
    Set aer = ws.Protection.AllowEditRanges("User Range")
    aer.Users("Power Users").Delete
End Sub

Remove user edit range

 
Sub RemoveUserEditRange()
    Dim ws As Worksheet, rng As Range, aer As AllowEditRange
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Unprotect
    For Each aer In ws.Protection.AllowEditRanges
        aer.Delete
    Next
End Sub

Show Protection Properties

 
Sub ShowProtectionProperties()
    Dim ws As Worksheet, prot As Protection
    Set ws = ThisWorkbook.Sheets("Protection")
    Set prot = ws.Protection
    Debug.Print prot.AllowDeletingColumns
    Debug.Print prot.AllowDeletingRows
    Debug.Print prot.AllowFiltering
    Debug.Print prot.AllowSorting
    Debug.Print prot.AllowUsingPivotTables
    Debug.Print prot.AllowFormattingCells
    Debug.Print prot.AllowFormattingColumns
    Debug.Print prot.AllowFormattingRows
    Debug.Print prot.AllowInsertingColumns
    Debug.Print prot.AllowInsertingRows
    Debug.Print prot.AllowInsertingHyperlinks
End Sub

Unprotect worksheet

 
Sub UnprotectWS()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Protection")
    ws.Unprotect "Excel2003"
End Sub