Bill,
I had the same problem exactly. I couldn't believe that
Excel would do all the work to conditionally format a
cell and then simply forget what it had done. There MUST
be a property called "CurrentFormat" or something, I
thought - until I found I wasn't alone.
Anyway, I decided to fix it, and here's the result. It
seems to work, but do please let me know if you find
anything wrong with it.
Sub detectRedCells()
' Detect cells with red interior colour put there by
conditional formatting
' Much quicker if sheet is protected and only cells of
interest are unlocked
' e.g. cells for data entry that may contain an error
indicated by a red interior
Dim c As Range
Dim r As Boolean
Dim a As String
' This assumes the cells of interest are unlocked
ActiveSheet.Protect
Set c = ActiveSheet.UsedRange.Cells(1, 1)
While Not c Is Nothing
r = False
If c.FormatConditions.Count <> 0 Then r =
checkCFormats(c)
' Here it compiles a list of red cells to display when
it's finished
If r Then a = a & c.Address & vbLf
If c.Next.Row <= c.Row And c.Next.Column <=
c.Column Then
Set c = Nothing
Else
Set c = c.Next
End If
Wend
MsgBox a
ActiveSheet.Unprotect
End Sub
Private Function checkCFormats(Cl As Range) As Boolean
' Return True if Cl is conditionally formatted with a
red interior
' Cl is known to have 1 or more FormatConditions
Dim n As Long
With Cl
For n = 1 To .FormatConditions.Count
If .FormatConditions(n).Interior.Color = vbRed
Then
If checkOneCF(Cl, .FormatConditions(n))
Then
checkCFormats = True
Exit Function
End If
End If
Next
End With
End Function
Private Function checkOneCF(Cl As Range, fCond As
FormatCondition) As Boolean
With fCond
If .Type = xlCellValue Then
checkOneCF = testCellValue(Cl.Value, fCond)
Else
checkOneCF = testFormula(fCond.Formula1)
End If
End With
End Function
Private Function testCellValue(Val As Variant, fCond As
FormatCondition) As Boolean
Dim v As Double
Dim f As Double
With fCond
v = CDbl(Val)
f = CDbl(.Formula1)
Select Case .Operator
Case xlEqual
testCellValue = (v = f)
Case xlNotEqual
testCellValue = (v <> f)
Case xlBetween
testCellValue = (v >= f) And (Val <= CDbl
(.Formula2))
Case xlNotBetween
testCellValue = (v < f) And (Val > CDbl
(.Formula2))
Case xlGreater
testCellValue = (v > f)
Case xlLess
testCellValue = (v < f)
Case xlGreaterEqual
testCellValue = (v >= f)
Case xlLessEqual
testCellValue = (v <= f)
End Select
End With
End Function
Private Function testFormula(Fm As String) As Boolean
On Error Resume Next
testFormula = Evaluate(Fm)
End Function
