Hi
OK. Try this.
Code:
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
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