PDA

View Full Version : Solved: Perform action based on conditional formatted colour?



Simon Lloyd
06-28-2009, 11:56 PM
Hi all, i'm trying to simply copy a cells value if the cell is conditionally formatted as red, i have tried: If MyCell.Formatconditions.item(1).Operator=xlGreater.....and i have triedIf MyCell.Formatconditions.interior.colorindex= 3...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
06-29-2009, 01:08 AM
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:



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

georgiboy
06-29-2009, 01:43 AM
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

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
Hope this helps

Simon Lloyd
06-29-2009, 08:37 AM
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
06-29-2009, 11:55 AM
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: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 NTI 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
06-29-2009, 12:14 PM
Hi Simon,
Can you post a sample showing your formatting?

Simon Lloyd
06-29-2009, 12:27 PM
Sure Malcolm :)
Sample attached.

mdmackillop
06-29-2009, 12:49 PM
This should return the test value against which you can compare the cell value as in the conditional format


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

rbrhodes
06-29-2009, 01:01 PM
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:



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

Simon Lloyd
06-29-2009, 01:01 PM
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.
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:

mdmackillop
06-29-2009, 01:06 PM
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
06-29-2009, 01:18 PM
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
06-29-2009, 01:23 PM
My simple example will fail if there is no "=" in the conditional format. Are there occasions where that might happen?

Simon Lloyd
06-29-2009, 02:08 PM
Well there are no = simply the built in CellIs>xlGreater>2

Trebor76
06-29-2009, 11:07 PM
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
06-30-2009, 12:20 AM
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
06-30-2009, 02:23 AM
'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

Trebor76
06-30-2009, 05:13 AM
Hi MD,

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

Kind regards,

Robert

Simon Lloyd
07-04-2009, 12:54 AM
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
07-04-2009, 01:18 AM
Hi Simon,

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

mdmackillop
07-04-2009, 01:36 AM
Hi dr,
If I make both values 2, your code marks the adjoining cells. As Simon says, you will always get MyColour = 3, regardless of cell value

rbrhodes
07-04-2009, 02:05 AM
Hi MD,

The last vesion checks for CF op is "Greater than" and CF colour "=3" with an AND. Works for me no matter what the value or colour of the cells.

On a serious note, please post an example that doesn't work so I can understand.

thanks!

mdmackillop
07-04-2009, 02:05 AM
Try this, which should be 2007 compatible. It includes two tests for different CF both returning Red result

Sub Test()
Dim Cel As Range
Dim Op As Long, Val As Long, Col As Long
For Each Cel In Range("A1:A20")
Op = Cel.FormatConditions(1).Operator
Val = Evaluate(Cel.FormatConditions(1).Formula1) 'Evaluation added for 2007
Col = Cel.FormatConditions(1).Interior.ColorIndex
If Col = 3 Then
Select Case Op
Case xlGreater
If Cel > Val Then
Cel.Offset(, 1) = "Greater"
Else
Cel.Offset(, 1) = "False"
End If
Case xlLess
If Cel < Val Then
Cel.Offset(, 1) = "Less"
Else
Cel.Offset(, 1) = "False"
End If
End Select
End If
Next
End Sub

mdmackillop
07-04-2009, 02:09 AM
Hi dr
This is my result (using 2007). I think there may be version issues here

Simon Lloyd
07-04-2009, 02:53 AM
rb, thanks again for looking at it, it seems, although it may be something with my sheet, that the code is looking at the CF settings rather than satisfied conditions, all my cells in the row being used have conditional formatting of xlgreater and Red, i only need to perform the action on a cell that has satisfied the conditions and the cell shows as red, for some reason. See the attached so you can see what i mean, it uses your code, slightly adapted to simply show the address of all that would be processed with your code, however it should only process J12, AB12 & AE12 as those are the only cells that have the CF satisfied on row 12.

Im using xl2003 here

mdmackillop
07-04-2009, 03:02 AM
Try this tweak to the code

Option Explicit
Sub CF()
Dim cel As Range
Dim rng As Range
Dim myOp As Long
Dim myCell As Range
Dim myColour As Long, msg
Dim myVal As Long
Set rng = Sheets("24HR Summary").Range("A12:AJ12")
For Each cel In rng
On Error Resume Next
With cel.FormatConditions(1)
myColour = .Interior.ColorIndex
myOp = .Operator
myVal = Evaluate(.Formula1)
End With
If myColour = 3 And myOp = 5 And cel > myVal Then
msg = msg & vbNewLine & cel.Address
End If
myColour = 0
myOp = 0
Next cel
MsgBox msg
Set cel = Nothing
Set rng = Nothing
Set myCell = Nothing

End Sub

Simon Lloyd
07-04-2009, 03:11 AM
Malcolm, thats closer, it will show all the addresses of any CF'd cell that has a value greater than zero, but sadly still not right.

mdmackillop
07-04-2009, 03:15 AM
If you put a break on the msg line, what value do you see for myVal?

Simon Lloyd
07-04-2009, 03:15 AM
I meant to mention that myVal = Evaluate(.Formula1) evaluates to 0 in your test

Simon Lloyd
07-04-2009, 03:17 AM
here's what i usedSub CF1()
Dim cel As Range
Dim rng As Range
Dim myOp As Long
Dim myCell As Range
Dim myColour As Long, msg
Dim myVal As Long
Set rng = Sheets("24HR Summary").Range("A12:AJ12")
For Each cel In rng
On Error Resume Next
With cel.FormatConditions(1)
myColour = .Interior.ColorIndex
myOp = .Operator
myVal = Evaluate(.Formula1)
End With
If myColour = 3 And myOp = 5 And cel > myVal Then
msg = msg & vbNewLine & cel.Address & " - " & myVal
End If
myColour = 0
myOp = 0
Next cel
MsgBox msg
Set cel = Nothing
Set rng = Nothing
Set myCell = Nothing

End Sub

mdmackillop
07-04-2009, 03:20 AM
Try

myVal = .Formula1

xld
07-04-2009, 03:24 AM
Simon,

I am a tad late to this paty and I haven't read all posts in the thread fully, but you simply seem to be testing if CF is set not if it is satisfied.

This seems to do what you want



Sub CF()

Dim cel As Range
Dim rng As Range
Dim myOp As Long
Dim myCell As Range
Dim myColour As Long, msg

Set rng = Sheets("24HR Summary").Range("A12:AJ12")
For Each cel In rng

On Error Resume Next
If cel.FormatConditions.Count > 0 Then

If cel.Value > cel.FormatConditions(1).Formula1 Then

msg = msg & vbNewLine & cel.Address
End If
End If

myColour = 0
myOp = 0
Next cel

MsgBox msg
Set cel = Nothing
Set rng = Nothing
Set myCell = Nothing

End Sub

mdmackillop
07-04-2009, 03:27 AM
Hi Bob,
I'm getting the code to work on 2007 & 2003, but Simon is getting differing results. His test for Formula1 is coming up as 0, not 2 as expected.

xld
07-04-2009, 03:42 AM
I tried it on his workbook Malcolm, and it worked fine. Odd problem.

Trebor76
07-04-2009, 03:44 AM
Hi Guys,

This might not the most ideal way (and again I'm a novice compare to you) but what if the code incorporates the same formula as the Conditional Format once it's determined the cell in question indeed has a Conditional Format applied to it (red interior in this case) i.e.


Option Explicit
Sub CF()
Dim cel As Range
Dim rng As Range
Dim myOp As Long
Dim myCell As Range
Dim myColour As Long, msg
Set rng = Sheets("24HR Summary").Range("A12:AJ12")
For Each cel In rng
On Error Resume Next
With cel.FormatConditions(1)
myColour = .Interior.ColorIndex
'myOp = .Operator
End With
'If myColour = 3 And myOp = 5 Then
If myColour = 3 And cel.Value >= 2 Then
msg = msg & vbNewLine & cel.Address
End If
myColour = 0
myOp = 0
Next cel
MsgBox msg
Set cel = Nothing
Set rng = Nothing
Set myCell = Nothing

End Sub

I ran this in Excel 2003 and the message box displayed the three Conditional Formatted cells (J12, AB12 and AE12).

HTH

Robert

xld
07-04-2009, 03:47 AM
That is the same way as I did it Robert, you just add a few more tests which would be useful if Simon adds extra conditions, for blue and green say, and you hardcode the value, I get it from Formula1..

Simon Lloyd
07-04-2009, 03:48 AM
Bob, yours worked perfect!, Malcolm, your latest adjustment myval= .formula1 also worked a treat, i swear i've tried a million diferent combinations for the formula and operators but all produced the results we were getting previously.....glad we got to the bottom of it as there is a case of stella at home that was going to be decimated!!! :)

Thanks again to Bob, Malcolm and rb!

Simon Lloyd
07-04-2009, 03:50 AM
Robert, thanks for sticking with it, i cannot hard code the value as in the real world each of the values will be different which is why i didn't do that in the first place.....far too much coding, but glad you found a solution too :)

Simon Lloyd
07-04-2009, 03:51 AM
Hi Bob,
I'm getting the code to work on 2007 & 2003, but Simon is getting differing results. His test for Formula1 is coming up as 0, not 2 as expected.I can't imagine, but is there a Excel setting that may affect that?

mdmackillop
07-04-2009, 03:51 AM
Hi Robert,
If you look at my sample in Post #23, i've used a slightly more complex test with differing colours and conditions

mdmackillop
07-04-2009, 03:54 AM
I can't imagine, but is there a Excel setting that may affect that?
I just posted on this incompatibilty here (http://www.vbaexpress.com/forum/showpost.php?p=189337&postcount=24)

xld
07-04-2009, 04:08 AM
Bob, yours worked perfect!

Just needs a real programmer to look at it :rotlaugh:

xld
07-04-2009, 04:10 AM
I just posted on this incompatibilty here (http://www.vbaexpress.com/forum/showpost.php?p=189337&postcount=24)

Have you seen my webpage on CF conditions. I use Evaluate in this when the test is a formula not a condition. I need to test this and update it if that behaviour happens in 2007, but CF in 2007 is so different (and such a mess IMO).

Simon Lloyd
07-04-2009, 06:19 AM
Just needs a real programmer to look at it :rotlaugh:We appreciate the intervention from such an omnipotent level.

On behalf of my fellow incompetents
.................:devil2:
Simon......Malcolm........rb...........Robert
:bow:......... :bow:......... :bow:............:bow: