Auto Protect

[pradyuthal]

I have the following Vb code with which I can suceesfully protect and unprotect formula cells. I want to get the unprotected formula cells ( with the help of unprotect vb code ) protected automatically whenever i close the excel file.

Sub lock_formulas()
'Erik Van Geit
'060914

Dim SH As Worksheet
Dim rng As Range

On Error Resume Next

    For Each SH In Worksheets
    SH.Unprotect
    
        With SH.UsedRange
        .Locked = False
        Set rng = Nothing
        Set rng = .SpecialCells(xlCellTypeFormulas)
        If Not rng Is Nothing Then rng.Locked = True
        End With
        
    SH.Protect
    Next SH

End Sub

Sub unlock_formulas()
'Erik Van Geit
'060914

Dim SH As Worksheet
Dim rng As Range

On Error Resume Next

    For Each SH In Worksheets
    SH.Unprotect
    
        With SH.UsedRange
        .Locked = False
        Set rng = Nothing
        Set rng = .SpecialCells(xlCellTypeFormulas)
        If Not rng Is Nothing Then rng.Locked = False
        End With
        
    SH.Unprotect
    Next SH

End Sub

EDIT:

The mind of an Excel-lover is full of structure. It loves reading code which is indented: analysing is quicker: so every effort can go to the problem itself...

Added Code tags - Smitty

 

[Smitty]

How about using the Before Close event:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call lock_formulas
End Sub

HTH,

Smitty

 

[erik.van.geit]

The mind of an Excel-lover is full of structure. It loves reading code which is indented: analysing is quicker: so every effort can go to the problem itself...

To let the code stay indented do the following.
Click "reply"
write your message
select your code
click the "Code"-button
(or Click code button, paste your code, click "Code" button again.)
Submit

A real relief for those who try to help you !

Sub lock_formulas() 
'Erik Van Geit 
'060914 

Dim SH As Worksheet 
Dim rng As Range 

On Error Resume Next 

    For Each SH In Worksheets 
    SH.Unprotect 
    
        With SH.UsedRange 
        .Locked = False 
        Set rng = Nothing 
        Set rng = .SpecialCells(xlCellTypeFormulas) 
        If Not rng Is Nothing Then rng.Locked = True 
        End With 
        
    SH.Protect 
    Next SH 

End Sub

 

[pradyuthal]

The following code protects all the blank cells also in addition to the cells containing formulas . But I  do not want to protect blank ones .
Please modify the following code .
Sub lock_formulas() 
'Erik Van Geit 
'060914 

Dim SH As Worksheet 
Dim rng As Range 

On Error Resume Next 

    For Each SH In Worksheets 
    SH.Unprotect 
    
        With SH.UsedRange 
        .Locked = False 
        Set rng = Nothing 
        Set rng = .SpecialCells(xlCellTypeFormulas) 
        If Not rng Is Nothing Then rng.Locked = True 
        End With 
        
    SH.Protect 
    Next SH 

End Sub

 

[erik.van.geit]

thank you for indenting the code

it doens't lock the blank cells for me: I can still write in them
also the constants are not protected

try out an extra line rng.select to check
the affected range will be selected
are there cells selected which you didn't expect ?

Sub lock_formulas()
'Erik Van Geit
'060914

Dim SH As Worksheet
Dim rng As Range

On Error Resume Next

    For Each SH In Worksheets
    SH.Unprotect
        With SH.UsedRange
        .Locked = False
        Set rng = Nothing
        Set rng = .SpecialCells(xlCellTypeFormulas)
            If Not rng Is Nothing Then
            rng.Locked = True
            rng.Select
            End If
        End With
        
    SH.Protect
    Next SH

End Sub

kind regards,
Erik

 

[pradyuthal]

This code works fine by selecting the affected cells .

But the following code as suggested does not work in all workbooks :

Private Sub Workbook_BeforeClose(Cancel As Boolean) 
    Call lock_formulas 
End Sub

I get the lock_formula and unlock_formulas code worked by way of integrating these by creating a menu with the help of the following code :

    Option Explicit
    
Sub CreateMenu()
'   This sub should be executed when the workbook is opened.
'   NOTE: There is no error handling in this subroutine

    Dim MenuSheet As Worksheet
    Dim MenuObject As CommandBarPopup

    Dim MenuItem As Object
    Dim SubMenuItem As CommandBarButton
    Dim Row As Integer
    Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId

''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Location for menu data
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
''''''''''''''''''''''''''''''''''''''''''''''''''''

'   Make sure the menus aren't duplicated
    Call DeleteMenu
    
'   Initialize the row counter
    Row = 2

'   Add the menus, menu items and submenu items using
'   data stored on MenuSheet
    
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        With MenuSheet
            MenuLevel = .Cells(Row, 1)
            Caption = .Cells(Row, 2)
            PositionOrMacro = .Cells(Row, 3)
            Divider = .Cells(Row, 4)
            FaceId = .Cells(Row, 5)
            NextLevel = .Cells(Row + 1, 1)
        End With
        
        Select Case MenuLevel
            Case 1 ' A Menu
'              Add the top-level menu to the Worksheet CommandBar
                Set MenuObject = Application.CommandBars(1). _
                    Controls.Add(Type:=msoControlPopup, _
                    Before:=PositionOrMacro, _
                    Temporary:=True)
                MenuObject.Caption = Caption
            
            Case 2 ' A Menu Item
                If NextLevel = 3 Then
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
                Else
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
                    MenuItem.OnAction = PositionOrMacro
                End If
                MenuItem.Caption = Caption
                If FaceId <> "" Then MenuItem.FaceId = FaceId
                If Divider Then MenuItem.BeginGroup = True
            
            Case 3 ' A SubMenu Item
                Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
                SubMenuItem.Caption = Caption
                SubMenuItem.OnAction = PositionOrMacro
                If FaceId <> "" Then SubMenuItem.FaceId = FaceId
                If Divider Then SubMenuItem.BeginGroup = True
        End Select
        Row = Row + 1
    Loop
End Sub

Sub DeleteMenu()
'   This sub should be executed when the workbook is closed
'   Deletes the Menus
    Dim MenuSheet As Worksheet
    Dim Row As Integer
    Dim Caption As String
    
    On Error Resume Next
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
    Row = 2
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        If MenuSheet.Cells(Row, 1) = 1 Then
            Caption = MenuSheet.Cells(Row, 2)
            Application.CommandBars(1).Controls(Caption).Delete
        End If
        Row = Row + 1
    Loop
    On Error GoTo 0
End Sub

This code is written the excel sheet under Microsoft Excel Object [Sheet1(Menusheet)]

Private Sub Workbook_Open()
    Call CreateMenu
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call DeleteMenu
End Sub

Please help me by providing a suitable vb code so that I can apply the method , that is , whenever I close any workbook containing the unprotected formula cells get protected automatically

 

[erik.van.geit]

please post your explanatory text normally and your code

between codetags

I do not see why you are posting code about creating menus
this has no influence on the code itself

if you can make it work on one sheet, you can make it work on any sheet ...
I'm not sure what you mean by

This code works fine by selecting the affected cells .

does the code work as intended ?? (not talking about other workbooks, but just the active workbook)

Sub lock_formulas() 
'Erik Van Geit 
'060914 

Dim SH As Worksheet 
Dim rng As Range 

On Error Resume Next 

    For Each SH In Worksheets 
    SH.Unprotect 
        With SH.UsedRange 
        .Locked = False 
        Set rng = Nothing 
        Set rng = .SpecialCells(xlCellTypeFormulas) 
            If Not rng Is Nothing Then 
            rng.Locked = True 
            rng.Select 
            End If 
        End With 
        
    SH.Protect 
    Next SH 

End Sub

it is protecting all formulacells on all sheets, nothing else, nothing less

best regards,
Erik