• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Scan for conditionally colored cells then copy, paste row to another sheet

E

Electron_Sam78

New Member
Hello, I'm trying to get some code for a specific tasks. I'm less than a noob at Excel VBA and I'm currently working on a maintenance task sheet for a couple of generators and need help. I have successfully created button macros to input dates but now I think I'm in over my head. I would like a macro to copy all the cells that are RED (due to a condition rule) plus their associated fields to the left from worksheet "Schedule" to worksheet "Tasks Due". Any help is much appreciated. I've also posted this at: excel forums and ozgrid forums but with almost no responses. Perhaps it's just too daunting a task...


Here's the pre-programming flow, I just don't know the code to do it:


Scan worksheet "Schedule" for red cells in following Range


H8:I16,H18:I22,H24:I35,H37:I41,H43:I49,H51:I59,H61:I72,H74:I75,H77:I84,H86:I89,H91:H100


If cell = red Then Copy Row A:I


Insert Associated Row into sheet ("Tasks Due")

If red cell is in worksheet "Schedule" H8:I16 then insert copied cells in worksheet "Tasks Due" one below cell = Fuel System

If red cell is in worksheet "Schedule" H18:I22 then insert copied cells in worksheet "Tasks Due" one below cell = Lubrication System

If red cell is in worksheet "Schedule" H24:I35 then insert copied cells in worksheet "Tasks Due" one below cell = Cooling System

If red cell is in worksheet "Schedule" H37:I41 then insert copied cells in worksheet "Tasks Due" one below cell = Exhaust System

If red cell is in worksheet "Schedule" H43:I49 then insert copied cells in worksheet "Tasks Due" one below cell = DC Electrical System

If red cell is in worksheet "Schedule" H51:I59 then insert copied cells in worksheet "Tasks Due" one below cell = AC Electrical System

If red cell is in worksheet "Schedule" H61:I72 then insert copied cells in worksheet "Tasks Due" one below cell = Engine And Mounting

If red cell is in worksheet "Schedule" H74:I75 then insert copied cells in worksheet "Tasks Due" one below cell = Remote Control System

If red cell is in worksheet "Schedule" H77:I84 then insert copied cells in worksheet "Tasks Due" one below cell = Main Alternator

If red cell is in worksheet "Schedule" H86:I89 then insert copied cells in worksheet "Tasks Due" one below cell = General Condition of Equipment

If red cell is in worksheet "Schedule" H91:H100 then insert copied cells in worksheet "Tasks Due" one below cell = Load Bank - ADMIN ONLY


I pasted the following fuinctions from http://www.cpearson.com/Excel/CFColors.htm into my sheet: ActiveCondition , ColorOfCF, and GetStrippedValue. It seems to work to identify a number value of the conditionally colored cell if I use ColorOfCF formula such as =ColorOfCF(H8,FALSE) in a cell in the worksheet. So, now how do I get it to work to automatically scan a certain range of cells for a red (or 255 according to ColorOfCF)? Then if it finds red (or the value 255) it copies the row it's in to another worksheet.


Thanks in advance!
 
While it is possible to detect conditional colors, its a little tricky, and not 100% reliable. IT would be better if we could just use the same condition that the CF formula is using. If you select the cell, and then go to Conditional Formatting, you should be able to see what the rule is to determine what cells are red. If you can relay that info to us, it will help a lot to filter/pick which cells to copy.


Also, for each of your conditions, I'm not quite sure what this phrasing means "one below cell = AC Electrical System"

Does that mean to find the cell with phrase at end, and paste 1 cell below, or 1 cell below last cell with comments and fill in with the phrase?
 
I have different conditional rules applied to many different cells so that might make your suggestion a bit more challenging. As I stated the ColorOfCF function does work to identify the cell interior color. The value that ColorOfCF returns for red (the color I'm concerned with) is 255. Yes, "one below cell = xxxxxxxx" means to find the cell with that phrase and paste 1 cell below it.


I'm working on posting a link to my doc
 
here is my doc in 2007 Excel http://speedy.sh/bKFmH/Generator-Service-Schedule-Kohler-combined-with-shortcut-buttons-UNSIGNED.xlsm
 
That helps. Next question, if we find a red cell in H16, are we just copying H16, or the entire row, or H16:I16?
 
Do we really need to check both col H and I, or will both cells always be red?
 
Okay, I think I've got it. Admittedly, I can't access files from my location, but you've helped me a lot understand the main things. Note that I wrote 2 macros, since we're repeating an operation multiple times, and it makes things a little simpler. I took your words literally as "insert" so that as macro scans sheets it's inserting the cells below the appropriate title. If we find 1 red cell in a row, we just go ahead and copy that section and then look at next row (since we already copied). Please let me know if this needs further tweaking (what went wrong, error messages, etc).

[pre]
Code: 
Sub MainMacro()
Application.ScreenUpdating = False
Worksheets("Schedule").Select
Call TransferData(Range("H8:I16"), "Fuel System")
Call TransferData(Range("H18:I22"), "Lubrication System")
Call TransferData(Range("H24:I35"), "Cooling System")
Call TransferData(Range("H37:I41"), "Exhaust System")
Call TransferData(Range("H43:I49"), "DC Electrical System")
Call TransferData(Range("H51:I59"), "AC Electrical System")
Call TransferData(Range("H61:I72"), "Engine And Mounting")
Call TransferData(Range("H74:I75"), "Remote Control System")
Call TransferData(Range("H77:I84"), "Main Alternator")
Call TransferData(Range("H86:I89"), "General Condition of Equipment")
Call TransferData(Range("H91:I100"), "Load Bank - ADMIN ONLY")

Application.ScreenUpdating = True
End Sub

Sub TransferData(r As Range, destCell As String)
Dim iRow As Long
Dim iCol As Long
Dim sourceRow As Long

iRow = 1
iCol = 1
Do Until iRow > r.Rows.Count
If ColorOfCF(r.Cells(iRow, iCol), False) = 255 Then
'Transfer data
sourceRow = r.Cells(iRow, iCol).Row
Range(Cells(sourceRow, "A"), Cells(sourceRow, "I")).Copy
Worksheets("Tasks Due").Cells.Find(destCell).Offset(1, 0).Insert Shift:=xlDown
Application.CutCopyMode = False

'Move counters to next row
iRow = iRow + 1
iCol = 1

Else
'If red cell not found, go to next column
iCol = iCol + 1

'If at last col already, go to next row, first col
If iCol > r.Columns.Count Then
iCol = 1
iRow = iRow + 1
End If
End If
Loop

End Sub
[/pre]
 
Wow, thanks for the help! I assigned the main macro to a button and when I executed it I got an error in the ActiveCondition function - not your code. Strange that it ran fine when it was used by ColorOfCF in the worksheet with a formula but now it's throwing a fit. The error is: Runtime error: '9': Subscript out of range. The code line: "Select Case FC.Type" is the one the debugger highlights. I know this isn't your code but can you look it over? I've "highlighted the problem line with *********

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
 
Here's ColorOfCF and GetStrippedValue as well (for reference):

[pre]
Code: 
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

Function ColorOfCF(Rng As Range, Optional OfText As Boolean = False) As Long

Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
If OfText = True Then
ColorOfCF = Rng.Font.Color
Else
ColorOfCF = Rng.Interior.Color
End If
Else
If OfText = True Then
ColorOfCF = Rng.FormatConditions(AC).Font.Color
Else
ColorOfCF = Rng.FormatConditions(AC).Interior.Color
End If
End If

End Function
[/pre]
 
Bah. From Pearson's page:

NOTE: ActiveCondition may result in an inaccurate result if the following are true:


You are calling ActiveCondtion from a worksheet cell, AND

The cell passed to ActiveCondtion uses a "Formula Is" rather than

"Cell Value Is" condition, AND

The formula used in the condition formula contains relative addresses
Click to expand...

This is part of the reason why using CF colors is so tricky. =/
 
ah well, if it's gonna be too tricky, I could post all the conditional format formulas. I have 18 altogether. Nine of them apply to column H and 9 apply to column I. LOL! Are you regretting this yet?


P.S. oh and there might be a couple that only apply to individual, unique cells


P.S.S. and each cell has unique values it relies on to format that cell using the conditional formula. Wow! Maybe I;m stuck with manually selecting all the red cell rows and copy/pasting them.
 
Okay, different approach. I used Rick's DisplayedColor UDF from:

http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-conditional-formatting-not-338/#post1168


With that in place, the TransferData macro becomes:

[pre]
Code: 
Sub TransferData(r As Range, destCell As String)
Dim iRow As Long
Dim iCol As Long
Dim sourceRow As Long

iRow = 1
iCol = 1
Do Until iRow > r.Rows.Count
'If ColorOfCF(r.Cells(iRow, iCol), False) = 255 Then
If DisplayedColor(r.Cells(iRow, iCol)) = 3 Then
'Transfer data
sourceRow = r.Cells(iRow, iCol).Row
Range(Cells(sourceRow, "A"), Cells(sourceRow, "I")).Copy
Worksheets("Tasks Due").Cells.Find(destCell).Offset(1, 0).Insert Shift:=xlDown
Application.CutCopyMode = False

'Move counters
iRow = iRow + 1
iCol = 1

Else
'If red cell not found, go to next column
iCol = iCol + 1

'If at last col already, go to next row, first col
If iCol > r.Columns.Count Then
iCol = 1
iRow = iRow + 1
End If
End If
Loop

End Sub
[/pre]
Note that I'm assuming a ColorIndex of 3 for red. This is the default color index for red, so hoping it works.
 
Thanks. I tried it but it gave me an error. I was running out the door and didn't have time to write it down. I will look at it agin tomorrow and let you know. I can remember it was an error in the other guy's code not yours. I was reading some logs from another linked forum and it seems that code has problems running in Excel 2007. :-
 
Let me know what you find out. I did try running it on my machine (using Office 2007) and it ran okay. But I suppose it depends on the exact type of CF being used. =/
 
It was another runtime error '9': subscript out of range. The debugger highlighted a line in the DisplayedColor function. I've "highlighted" it with stars *****


Were you able to download my document?

[pre]
Code: 
' 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
If CellInterior Then
DisplayedColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
Else
DisplayedColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
End If
Exit Function
End If
End With
Next
If CellInterior Then
DisplayedColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
DisplayedColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End Function
[/pre]
 
Here's a couple of my conditional formatting formulas:


For the weekly tasks: =7<=(DATEDIF(IF(E7="",$C$2,E7),$C$4,"d"))

For the monthly tasks: =31<=DATEDIF(IF(E28="",$C$2,E28),$C$4,"d")


THe rest are similar for the other interval tasks. I have semi-annual, annual, bi-annual, tri-annual, 5 yrs and 10 yrs. THere are also a couple of unique ones that are simpler like:


=$F$2>E12 which applies to H12 and =$F$3>E12 which applies to I12
 
Hmm. Well, I'm about out of ideas. I think we're going to have to go with using the CF logic to determine things, rather than trying to detect the CF. =/

There doesn't seem to be a good way to detect CF conditions.

http://stackoverflow.com/questions/996384/excel-2007-conditional-formatting-how-to-get-cell-color
 
Is there a way to do that without having to input all the CF formulas? Each cell has a relative cell that applies to it. That would be a major undertaking I would think. IF that's the case I'd say forget it.
 
A off-shoot of that idea would be to use a helper column that contains the CF formulas. Maybe use some sort of OR logic? Then the macro could just scan the one column for TRUE's and pull that data.


PS. Ha ha, now you're getting the hang of it! =P
 
Not necessarily. That's why I said you could use an OR function.

=OR(CF_condition_for_H,CF_condition_for_I)
 
You must log in or register to reply here.
Back
Top