How to Protect Cells in Excel with a Macro – Consolvus

Occasionally I am asked to create a protected Excel workbook where users are only able to enter data into specific cells. For example, in the above sheet users can only input into cream cells. This is done by unlocking the cells and protecting the worksheet.

Right-click the cell(s) and select Format Cells…
Select the Protection tab and uncheck Locked
Right-click the sheet name and select Protect Sheet…

Doing this for a large workbook would be time consuming and error prone. Therefore, I automate the process with a simple Excel macro which:

Looks at all the active cells on a worksheet
Locks and unlocks the cells depend on their colour
Protects the worksheet
Repeats for all the worksheets in the workbook

The code to do this is show below:

Option Explicit
'***
'Protects a workbook making only cells of a specified colour inputable
'1.  Looks at all the active cells on a worksheet
'2.  Locks and unlocks the cells depend on their colour
'3.  Protects the worksheet
'4.  Repeats for all the worksheets in the workbook
'
Sub ProtectSheets()

    Dim ColumnCount, ColumnIndex As Integer
    Dim RangeObject As Range
    Dim RowCount, RowIndex As Integer
    Dim SheetCount, SheetIndex As Integer

    SheetCount = ActiveWorkbook.Worksheets.Count
    For SheetIndex = 1 To SheetCount
        
        'Select sheet and unprotects
        Sheets(SheetIndex).Select
        ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
        
        'Selects populated cells on sheets
        Range("A1").Select
        Set RangeObject = Range(Selection, ActiveCell.SpecialCells(xlLastCell))
    
        ColumnCount = RangeObject.Columns.Count
        RowCount = RangeObject.Rows.Count
        For ColumnIndex = 1 To ColumnCount
            For RowIndex = 1 To RowCount
            
                'If cell is yellow unlock otherwise protect the cell
                If RangeObject.Cells(RowIndex, ColumnIndex).DisplayFormat.Interior.Color = 14483455 Then
                    RangeObject.Cells(RowIndex, ColumnIndex).Locked = False
                Else
                    RangeObject.Cells(RowIndex, ColumnIndex).Locked = True
                End If
                
                'If cell is blue change to no fill
                'If RangeObject.Cells(RowIndex, ColumnIndex).DisplayFormat.Interior.Color = 15194827 Then
                '    RangeObject.Cells(RowIndex, ColumnIndex).Interior.Pattern = xlNone
                '    RangeObject.Cells(RowIndex, ColumnIndex).Interior.TintAndShade = 0
                '    RangeObject.Cells(RowIndex, ColumnIndex).Interior.PatternTintAndShade = 0
                'End If
                
                'If cell contains formula make it green
                'If RowIndex > 17 And ColumnIndex > 2 Then
                '    If Left(RangeObject.Cells(RowIndex, ColumnIndex).Formula, 1) = "=" Then
                '        RangeObject.Cells(RowIndex, ColumnIndex).Interior.Color = 11979698
                '    End If
                'End If
                
                'If cell is yellow and contains a zero delete the zero
                'If RangeObject.Cells(RowIndex, ColumnIndex).DisplayFormat.Interior.Color = 14483455 Then
                '    If RangeObject.Cells(RowIndex, ColumnIndex).Value = 0 Then
                '        RangeObject.Cells(RowIndex, ColumnIndex).ClearContents
                '    End If
                'End If
                
            Next RowIndex
        Next ColumnIndex
        
        'If sheet is not Entity hide rows and freeze titles
        If ActiveSheet.Name <> "Entity" Then
            Rows("1:13").Select
            Selection.EntireRow.Hidden = True
            Range("C19").Select
            ActiveWindow.FreezePanes = True
        End If
        
        'Protects sheet
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Next SheetIndex
End Sub
'***
'Gets the color index of a specified cell. This colour can be used in ProtectCellByColour
'
Sub GetCellColour()
    Dim Range As Object
    
    'Sheets("Entity").Select
    Set Range = Application.ActiveCell
    MsgBox Range.DisplayFormat.Interior.Color
    Debug.Print Range.DisplayFormat.Interior.Color
End Sub
'***
'Unprotects all sheets in workbook.
'
Sub UnprotectSheets()
    Dim SheetCount, SheetIndex As Integer

    SheetCount = ActiveWorkbook.Worksheets.Count
    For SheetIndex = 1 To SheetCount
        Sheets(SheetIndex).Select
        ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
        
        ActiveWindow.FreezePanes = False
        Cells.Select
        Range("A14").Activate
        Selection.EntireRow.Hidden = False
        Range("A1").Select
        
    Next SheetIndex
End Sub

If you want any help with Oracle EPM please contact me.

How to Protect Cells in Excel with a Macro

Related