Hi
OK. Try this.
in a standard module, use Rick's FunctionCode: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
Code: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




Reply With Quote
Bookmarks