This doesn't look trivial to me.
But Chip Pearson did most of the work.
I went to his site:
http://www.cpearson.com/excel/CFColors.htm
And stole his ActiveCondition function.
(I did make a change to it because of an oddity in excel: See John Walkenbach's
site:
http://j-walk.com/ss/excel/odd/odd07.htm to see more information.)
I got help from both John and Bernie Deitrick on how to overcome this bleeping
oddity!
(Both John's and Bernie's tip seemed to work ok for me. I included (but
commented out) John's version. I used Bernie's (simply because it was more
simple!). (I think I would have had to activate a different worksheet in either
case. And if I have to activate a worksheet, I might as well just select the
cell!--it goes against a lot of things I've learned here, but you gotta do what
works.)
Chip's code is the workhorse. It determines which condition is active. The
code that calls it just removes the non-active format conditions and replaces
the activecondition with True. (so it always stays active).
So no matter what's in the cell, the conditional formatting that was there will
always apply (well, until you change it.)
I've included Chip's code here only because of the slight changes I made.
(The notes and most of the procedure came from a similar request:
http://groups.google.com/[email protected])
And had this followup:
One thing that I didn't think of (and I hope that it doesn't affect you).
If you have cells that evaluate to errors (1/0, ref, n/a type stuff), then the
ActiveCondition function blows up. The code uses a lot of .values.
===============
Try this against a copy of your worksheet--just in case.
Option Explicit
Sub testme()
Dim myRng As Range
Dim mycell As Range
Dim myCell_AC As Long
Dim wks As Worksheet
Dim i As Integer
Dim startCell As Range
Set startCell = ActiveCell
For Each wks In ActiveWorkbook.Worksheets
With wks
Set myRng = Nothing
On Error Resume Next
Set myRng = .Cells.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If myRng Is Nothing Then
'do nothing
Else
application.screenupdating = false
For Each mycell In myRng.Cells
If mycell.FormatConditions.Count = 0 Then
MsgBox "something bad happened with " & _
mycell.Address(external:=True)
'do nothing
Else
myCell_AC = ActiveCondition(mycell)
If myCell_AC = 0 Then
mycell.FormatConditions.Delete
Else
For i = mycell.FormatConditions.Count To 1 Step -1
If i = myCell_AC Then
mycell.Interior.ColorIndex _
= mycell.FormatConditions(i) _
.Interior.ColorIndex
End If
mycell.FormatConditions(i).Delete
Next i
End If
End If
Next mycell
application.screenupdating = true
End If
End With
Next wks
Application.Goto startCell
End Sub
Function ActiveCondition(Rng As Range) As Integer
Dim Ndx As Long
Dim FC As FormatCondition
Dim tmpRng As Range
Set tmpRng = Rng
Set Rng = Nothing
Set Rng = tmpRng
If Rng.FormatConditions.Count = 0 Then
ActiveCondition = 0
Else
For Ndx = 1 To Rng.FormatConditions.Count
Set FC = Nothing
Set FC = Rng.FormatConditions(Ndx)
Set FC = Rng.FormatConditions(Ndx)
Select Case FC.Type
Case xlCellValue
Select Case FC.Operator
Case xlBetween
If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlGreater
If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlEqual
If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlGreaterEqual
If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlLess
If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlLessEqual
If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlNotEqual
If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case xlNotBetween
If CDbl(Rng.Value) <= CDbl(FC.Formula1) Or _
CDbl(Rng.Value) >= CDbl(FC.Formula2) Then
ActiveCondition = Ndx
Exit Function
End If
Case Else
Debug.Print "UNKNOWN OPERATOR"
End Select
Case xlExpression
' John Walkenbach 's excel oddity page
'
http://j-walk.com/ss/excel/odd/odd07.htm
' describes the problem
'
' Bernie Deitrick's tip about selecting the cell first to make formula1
' work correctly works fine, too.
'
' from John's site:
' Dim F1 As String
' Dim F2 As String'
' Rng.Parent.Activate 'make F2 formula work with activecell.
' F1 = Rng.FormatConditions(1).Formula1
' F2 = Application.ConvertFormula(F1, xlA1, xlR1C1, , ActiveCell)
' F1 = Application.ConvertFormula(F2, xlR1C1, xlA1, , Rng)
' From Bernie's tip
Application.Goto Rng
If Application.Evaluate(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case Else
Debug.Print "UNKNOWN TYPE"
End Select
Next Ndx
End If
ActiveCondition = 0
End Function
