Solved: Perform action based on conditional formatted colour?

[Simon Lloyd]

Hi all, i'm trying to simply copy a cells value if the cell is conditionally formatted as red, i have tried:[VBA] If MyCell.Formatconditions.item(1).Operator=xlGreater.....[/VBA]and i have tried[VBA]If MyCell.Formatconditions.interior.colorindex= 3...[/VBA]But none pick up the formatting, the cells will only ever have one condition and it will always be xlGreater, the colour will always be red!

Any ideas?

[rbrhodes]

Hi Simon,

Well you were close. Here's what I figured out:

Operators are (as unlikely as it seems) numbered as they appear in the conditional formatting dialog:

1 = between
2 = not between
3= equal to
4= not equal to
5= greater than
6= less than
7= greater than or equal to
8= less than or equal to

Colours, well good luck. 3 _is_ red...

The vernacular is what you're looking for however:

[VBA]

Option Explicit
Sub Colour()
Dim myOp As Long
Dim myCell As Range
Set myCell = Range("A6")
myOp = myCell.FormatConditions(1).Interior.ColorIndex
If myOp = 3 Then
MsgBox ("Yup. It's red.")

End If
Set myCell = Nothing

End Sub
Sub Op()
Dim myOp As Long
Dim myCell As Range
Set myCell = Range("A6")
myOp = myCell.FormatConditions(1).Operator
Select Case myOp
Case Is = 1
MsgBox ("Between")
Case Is = 2
MsgBox ("Not between")
Case Is = 3
MsgBox ("Equal to")
Case Is = 4
MsgBox ("Not equal to")
Case Is = 5
MsgBox ("Greater than")
Case Is = 6
MsgBox ("Less than")
Case Is = 7
MsgBox ("Greater than or equal to")
Case Is = 8
MsgBox ("Less than or equal to")
Case Else

End Select
Set myCell = Nothing
End Sub

[/VBA]

[georgiboy]

Try this, it will copy the activecell and paste it to sheet2 range A1 if it is formatted as red (ColorIndex 3).

Look here.
http://www.cpearson.com/excel/CFcolors.htm

[vba]Sub CopyCell()

' Select activecell with CF and then run this sub.
' It will copy and paste the activecell to sheet2 range A1 if it
' is CF'd as ColorIndex = 3 (red)

If ColorIndexOfCF(ActiveCell) = 3 Then
ActiveCell.Copy Destination:=Sheet2.Range("A1")
End If

End Sub

Function ColorIndexOfCF(Rng As Range) As Integer
Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
ColorIndexOfCF = Rng.Interior.ColorIndex
Else
ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex
End If
End Function

Function ActiveCondition(Rng As Range) As Integer
Dim Ndx As Long
Dim FC As FormatCondition
Dim Temp As Variant
Dim Temp2 As Variant

If Rng.FormatConditions.Count = 0 Then
ActiveCondition = 0
Else
For Ndx = 1 To Rng.FormatConditions.Count
Set FC = Rng.FormatConditions(Ndx)
Select Case FC.Type
Case xlCellValue
Select Case FC.Operator

Case xlBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)

If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp And _
Rng.Value <= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If

Case xlGreater
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value > Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If

Case xlEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp = Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If


Case xlGreaterEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If


Case xlLess
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value < Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If

Case xlLessEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value <= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If


Case xlNotEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp <> Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If

Case xlNotBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)
If IsNumeric(Temp) Then
If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) And _
(CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Not Rng.Value <= Temp And _
Rng.Value >= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If

Case Else
Debug.Print "UNKNOWN OPERATOR"
End Select


Case xlExpression
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

Function GetStrippedValue(CF As String) As String
Dim Temp As String
If InStr(1, CF, "=", vbTextCompare) Then
Temp = Mid(CF, 3, Len(CF) - 3)
If Left(Temp, 1) = "=" Then
Temp = Mid(Temp, 2)
End If
Else
Temp = CF
End If
GetStrippedValue = Temp
End Function[/vba]
Hope this helps

[Simon Lloyd]

georgieboy, thanks for that i did see that huge function on the net, Chip Pearsons site i believe, however as i stated i do not need to test for every condition as i know my condition, i also do not need to check to see if the CF is FormulaIs or CellIs as i know that too!

rb, cheers, i didnt try that combination of losing .Item but adding (1) before .Interior, i'll try it a little later when i have access to the workbook i was working on, i hope i don't have to set MyCell as a specific cell as of course i am using MyCell in a loop through a range.

Thanks

[Simon Lloyd]

rb, it may be me but your suggestion will show the message box even if the cell does not satisfy the condition to be red, i tested it on a cell that has conditional formatting and is currently satisfying the condition, the message box shows, now use a cell that has the same formatting but does not satisfy the condition...the message box shows, i believe it is just picking up that the condition is set to be red.

here's the section of code i need to get working:[vba]Dim myOp As Long
Dim oCell As Range
Set Rng1a = ActiveSheet.Columns(1).Find(What:=RL, After:=ActiveSheet.Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
For Each MyCell In Sheets("24HR Summary").Range(Rng1a.Offset(0, 2).Address & ":" & _
Cells(Rng1a.Row, 256).End(xlToLeft).Address)
Set oCell = Range(MyCell.Address)
myOp = oCell.FormatConditions(1).Interior.ColorIndex
If myOp = 3 Then
'MsgBox MyCell.Address & " - " & MyCell.Value

ic = ic + 1

With Workbooks("feed reasons.xls").Sheets("Reasons")
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = RL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = TL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = SM
.Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Cells(1, MyCell.Column).Value
End With
End If
Next MyCell
Workbooks("feed reasons.xls").Close True
If ic = 0 Then GoTo NT[/vba]I simply cannot get it to recognise a cell that has the condition satisfied and is coloured red....anyone any further ideas?

The above is from a larger section of code which all works perfect including the above section if i use something like If MyCell >2 Then but stating the threshold for each column is far to much code and complexity.

[mdmackillop]

Hi Simon,
Can you post a sample showing your formatting?

[Simon Lloyd]

Sure Malcolm
Sample attached.

[mdmackillop]

This should return the test value against which you can compare the cell value as in the conditional format

[VBA]
myF = Split(oCell.FormatConditions(1).Formula1, "=")(1) * 1
If oCell > myF Then

[/VBA]

[rbrhodes]

Hi Simon,

I still think it works. When I tested the code on a non CF cell I get an error. I think that you have to re-set MyOp each time it finds a CF cell otherwise it will remain 3 and the test will give wrong results. Ex:


[VBA]
For Each MyCell In Sheets("24HR Summary").Range(Rng1a.Offset(0, 2).Address & ":" & _
Cells(Rng1a.Row, 256).End(xlToLeft).Address)
Set oCell = Range(MyCell.Address)

'//Clear the previous value (must be done in the loop)
myOp = 0

'//Allow the 'not found' error (you weren't getting one?)
On Error Resume Next

myOp = oCell.FormatConditions(1).Interior.ColorIndex

If myOp = 3 Then

'//Msgbox for testing
MsgBox MyCell.Address & " - " & MyCell.Value

'//Reset ErrorHandling to whatever you had
On Error Goto 0


ic = ic + 1



With Workbooks("feed reasons.xls").Sheets("Reasons")
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = RL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = TL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = SM
.Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Cells(1, MyCell.Column).Value
End With
End If
Next MyCell

[/VBA]

[Simon Lloyd]

Malcolm, thanks for the reply but that fails at the line you gave: myF = Split(oCell.FormatConditions(1).Formula1, "=")(1) * 1
the error is Application defined or object defined error.
[VBA]Dim Rng1a As Range, MyCell As Range
Dim oCell As Range, mf As Long
Application.ScreenUpdating = False
ic = 0
Workbooks.Open (ThisWorkbook.Path & "\feed reasons.xls")
ThisWorkbook.Activate
Sheets("24HR Summary").Visible = True
Sheets("24HR Summary").Activate
ActiveSheet.Unprotect Password:="Feedmgmnt"
Set Rng1a = ActiveSheet.Columns(1).Find(What:=RL, After:=ActiveSheet.Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
For Each MyCell In Sheets("24HR Summary").Range(Rng1a.Offset(0, 2).Address & ":" & _
Cells(Rng1a.Row, 256).End(xlToLeft).Address)


Set oCell = Range(MyCell.Address)
myF = Split(oCell.FormatConditions(1).Formula1, "=")(1) * 1
If oCell > myF Then
MsgBox MyCell.Address & " - " & MyCell.Value
ic = ic + 1

With Workbooks("feed reasons.xls").Sheets("Reasons")
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = RL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = TL
.Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = SM
.Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Cells(1, MyCell.Column).Value

End With
End If
Next MyCell
Workbooks("feed reasons.xls").Close True
If ic = 0 Then GoTo NT
Call explanation
NT:[/VBA]

[mdmackillop]

It may be a version problem. I'm using 2007 here. The Formula1 came from FormatCondition Object Members in VBA Help and in your sample simply returns "=2". The rest is just getting the numerical value from the string.

[Simon Lloyd]

It may be a version problem. I'm using 2007 here. The Formula1 came from FormatCondition Object Members in VBA Help and in your sample simply returns "=2". The rest is just getting the numerical value from the string.

md, firstly my apology for the error given, that was because there was 2 instances of todays date the first having no CF (as this is a test workbook), at the moment all the CF's are 2 but they will be varying numbers, the fault i get is subscript out of range Error 9, which AFAIK is it cannot find the specified worksheet but the debug stops here: myF = Split(oCell.FormatConditions(1).Formula1, "=")(1) * 1

Those Object members are in in 2003 too, i'd already been down that road. Any ideas why the SS out of range...the sheet is definitley the active one and the value of Split(oCell.FormatConditions(1).Formula1 when hovered shows 2 as it should be.

[mdmackillop]

My simple example will fail if there is no "=" in the conditional format. Are there occasions where that might happen?

[Simon Lloyd]

Well there are no = simply the built in CellIs>xlGreater>2

[Trebor76]

Hi Simon,

Though I'm a novice against you guys, let me know how this goes:

Sub Macro1()
    On Error GoTo EndMacro
 
    If ActiveCell.FormatConditions(1).Interior.ColorIndex = 3 Then
        MsgBox "The conditional format for this cell is Red"
    End If
    
EndMacro:
End Sub

HTH

Robert

[mdmackillop]

Hi Robert,
Welcome to VBAX.
Your code will return the value which will apply if the test is true. It does not look at the value in the cell, or show whether the cell is coloured by the CF.
FYI cel.interior.colorindex does not work with CF cells

Keep trying though!!!

Regards
MD

[rbrhodes]

[vba]

'Loop
For Each cel in rng

'Clear the previous value
myOp = 0


Set oCell = Range(MyCell.Address)

'Allow the 'not found' error if no CF
On Error Resume Next

'Get value (or error)
myOp = oCell.FormatConditions(1).Interior.ColorIndex

'Reset
On Error Goto 0 'Or whatever

If myOp = 3 Then

'Msgbox for testing
MsgBox "Yup. Is red by CF"


end if

next cel

[/vba]

[Trebor76]

Hi MD,

Thanks for that - I thought I was out of my league!!

Kind regards,

Robert

[Simon Lloyd]

Hi Guys, i have tried quite a bit with this still no joy, rb your suggestion simply saw the condition "If MyOp = 3" as true for each MyCell in range (as the conditional formatting would turn the cell red if the condition is satisfied) so it transferred all of the points, i think i'm getting VBA blind now as i can't seem to get past this very simple (or it started out that way) task!

Any further ideas?

[rbrhodes]

Hi Simon,

What if you test for both? Could it be that simple...