Lock Cells Based On Interior Colour Including Conditional Fomatting

[AerosAtar]

I have the following code in a Worksheet_Change() event that locks cells based on their interior colour.


Dim cell
For Each cell In ActiveSheet.Range("A1:Y160")
If cell.MergeCells = False Then
Select Case True
Case cell.Interior.ColorIndex = 15
cell.Locked = True
Case Else
cell.Locked = False
End Select
Else
Set mergedRange = cell.MergeArea
Select Case True
Case mergedRange.Interior.ColorIndex = 15
mergedRange.Locked = True
Case Else
mergedRange.Locked = False
End Select
End If
Next

This code works perfectly, locking all cells and mergeareas with a 25% grey background.

However, some cells/mergeareas contain conditional formatting to change the colour of the background. This conditional formatting is formula-based, as the formatting is based on the contents of other cell(s).

For example: mergearea(F6:O6)'s formatting is dependent on the value of cell(L4), while cell(Q126)'s formatting is based on the values of cells(Q138, F126 and B126).

This means that certain cells/mergeareas that should not be locked are being locked (due to having a default 25% grey background), while others that should be locked are not being locked (due to not having a default 25% grey brackgroud).

I've seen the code on Rick's thread (http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/), but I am not sure how to incorporate it into the above (or if there is another way of doing what I want). I am also aware of the DisplayFormat property, but unfortunately this is not an option as I need backward-compatability with Excel 2007 (some users are running 2007, while others are using 2010 - I am coding in 2007).

I may be able to upload the form that this code is being used in, but am currently seeking confirmation from my employer that I am permitted to do so.

[Admin]

Hi

Welcome to ExcelFox!!

Try this untested code. You have to define the color depending upon the other cells.


Dim Cell As Range
Dim mergedRange As Range

For Each Cell In ActiveSheet.Range("A1:Y160")
If Cell.MergeCells = False Then
Select Case True
Case Cell.Interior.ColorIndex = 15
Cell.Locked = True
Case Else
Cell.Locked = False
End Select
Else
Set mergedRange = Cell.MergeArea

Select Case mergedRange.Address(0, 0)
Case "F6:O6"
If Range("L4").Value = "Whatever" Then
mergedRange.Interior.ColorIndex = 15 'adjust the color index
mergedRange.Locked = True
Else
mergedRange.Interior.ColorIndex = 15 'adjust the color index
mergedRange.Locked = True
End If
Case "Q126"
'same as above

Case Else
Select Case True
Case mergedRange.Interior.ColorIndex = 15
mergedRange.Locked = True
Case Else
mergedRange.Locked = False
End Select
End If
Next

[AerosAtar]

Thanks for the reply (and welcome!).

If possible, I would prefer to avoid doing single-cell/mergearea specifications in the code. The form is quite complex, with a not-insignificant number of questions, and a significant number of those have impacts on other questions within the form. I already have too many absolute-references in some of the other code, which makes updating in when additional questions are inserted a real chore. (I realise that seeing the form would probably help explain all this, but I am still waiting on an answer from my employer).

If there is no other way, I will look at switching all of the conditional formatting into the code, but I was really hoping that wouldn't be necessary...

[Admin]

Hi

Create a mockup by putting some dummy values. Be careful that the format of the sheet is same in the mockup version as well.

[AerosAtar]

I have attached a stripped-down version of one page of the form.

1306

All of the code for the Command Button Click() events have been stripped out, since they won't work anyway without the rest of the workbook (not to mention being irrelevant to what I am asking about), and I have removed passwords, etc.

Hopefully this helps show what it is I need/want to accomplish.

[Admin]

Hi

Can you please try this one ?


Dim Cell As Range
Dim mergedRange As Range

Range("A1:Y160").Locked = False
For Each Cell In ActiveSheet.Range("A1:Y160")
If Cell.MergeCells = False Then
If Cell.FormatConditions.Count = 0 Then
If Cell.Interior.ColorIndex = 15 Then Cell.Locked = True
Else
If Cell.DisplayFormat.Interior.ColorIndex = 15 Then
If Cell.Borders.ColorIndex = xlNone Then
Cell.Locked = True
End If
End If
End If
Else
Set mergedRange = Cell.MergeArea
If mergedRange.FormatConditions.Count = 0 Then
If mergedRange.Interior.ColorIndex = 15 Then mergedRange.Locked = True
Else
'If Cell.Address = "$O$20" Then Stop
If mergedRange.DisplayFormat.Interior.ColorIndex = 15 Then
If mergedRange.Borders(xlEdgeTop).ColorIndex = xlNone Then
mergedRange.Locked = True
End If
End If
End If
End If
Next

[AerosAtar]

Unfortunately that code does not work due to the DisplayFormat property, which is not present in Excel 2007 (this line of the code:)


If mergedRange.DisplayFormat.Interior.ColorIndex = 15 Then

As stated in my original post, I need to ensure compatability with 2007 due to not all users having 2010 installed (me being one of them).

[Admin]

Hi

OK. Try this.


Dim Cell As Range
Dim mergedRange As Range
Dim xlVer As Long
Dim dColor As Long

xlVer = Val(Application.Version)

Range("A1:Y160").Locked = False
For Each Cell In ActiveSheet.Range("A1:Y160")
If Cell.MergeCells = False Then
If Cell.FormatConditions.Count = 0 Then
If Cell.Interior.ColorIndex = 15 Then Cell.Locked = True
Else
If xlVer > 12 Then
If Cell.DisplayFormat.Interior.ColorIndex = 15 Then
If Cell.Borders.ColorIndex = xlNone Then
Cell.Locked = True
End If
End If
Else
dColor = DisplayedColor(Cell, True)
If dColor = 15 Then
'If Cell.Borders.ColorIndex = xlNone Then
Cell.Locked = True
'End If
End If
End If
End If
Else
Set mergedRange = Cell.MergeArea
If mergedRange.FormatConditions.Count = 0 Then
If mergedRange.Interior.ColorIndex = 15 Then mergedRange.Locked = True
Else
'If Cell.Address = "$O$20" Then Stop
If xlVer > 12 Then
If mergedRange.DisplayFormat.Interior.ColorIndex = 15 Then
If mergedRange.Borders(xlEdgeTop).ColorIndex = xlNone Then
mergedRange.Locked = True
End If
End If
Else
dColor = DisplayedColor(mergedRange.Cells(1), True)
If dColor = 15 Then
If mergedRange.Borders(xlEdgeTop).ColorIndex = xlNone Then
mergedRange.Locked = True
End If
End If
End If
End If
End If
Next

in a standard module, use Rick's Function


Option Explicit


' Arguments
' ----------------
' Cell - Required Range, not a String value, for a **single** cell
'
' CellInterior - Optional Boolean (Default = True)
' True makes function return cell's Interior Color or ColorIndex based on
' the ReturnColorIndex argument False makes function return Font's Color or
' ColorIndex based on the ReturnColorIndex argument
'
' ReturnColorIndex - Optional Boolean (Default = True)
' True makes function return the ColorIndex for the cell property determined
' by the CellInterior argument False make function return the Color for the
' cell property determined by the CellInterior argument
'
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
Cell.Select
Test = Evaluate(.Formula1)
Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
On Error Resume Next
If CellInterior Then
DisplayedColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
Else
DisplayedColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
End If
If Err.Number <> 0 Then GoTo 1
Exit Function
End If
End With
Next
1:
If CellInterior Then
DisplayedColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
DisplayedColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
Err.Clear
End Function

[AerosAtar]

Unfortunately this does not work either - no cells get locked (however, see below).

If I change .Borders.ColorIndex = xlNone to .Borders.ColorIndex = 16, the the following behaviour is observed:

In 2007 the code still does not lock any cells/mergeareas, regardless of their colour.
In 2010 it locks some cells/mergeareas, but not others, and also does not unlock some cells/mergeareas after they have been locked the first time - it all seems to be getting applied inconsistently.


For example, it locks K64:L64, but not K65:L65. It also locks all of the cells/mergeareas in the Combined Fund Heading 'table' (F125:W137), but does not Unlock them when they should be available (set F10 to "Standard Proposal (Research)" and L89 to either "FEC" or "Non-FEC").

In addition, the code takes an excessive amount of time (>2 minutes) to execute in 2007, causing Excel to become non-responsive (even being reported in task manager as 'Not Responding') during that period.

[Admin]

Essentially which cells you want to lock/unlock ? Like, you do not want to lock those cells which is having a border or colorindex having 48 etc..

[AerosAtar]

Any cell with a light-grey displayed background (i.e. following conditional formatting) should be locked.

Any cell with a light-red/white displayed background should be unlocked.

The main complication arises from the fact that the displayed background of the cells will change based on the values in other cells (i.e. it will not always be the same cells that need to be locked).

[Admin]

Hi

IMHO, include all the conditions in the code and lock/unlock cells rather than depending on CF.