Hi John
Take a closer look at these 2 macros ore look at Chip Pearson WWW
Sub WhichMacroToRun()
'Leo Heuser, 8-6-2006
'// Modifyed by Joergen Bondesen, 8-6-2006
Dim Cell As Range
Dim CheckRange As Range
Dim FCNumber As Long
Set CheckRange = ActiveSheet.Cells. _
SpecialCells(xlCellTypeAllFormatConditions)
For Each Cell In CheckRange.Cells
FCNumber = ActiveCondition(Cell) ' Caling Chips funktion '****
If FCNumber 0 Then
Select Case Cell.FormatConditions(FCNumber).Interior _
.ColorIndex
Case Is = 3 'Red
'Run Macro1
Case Is = 50 'Green
'Run Macro2
Case Else
End Select
End If
Next Cell
End Sub
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< <<<<<<<<
Option Explicit
'----------------------------------------------------------
' Procedure : ConditionalsFormattingConvert
' Date : 20060607
' Author : Joergen Bondesen
' Modifyed by :
' Purpose : Finding all cells with displayed
' Conditionals Formatting Red and Green
' Note : Macro will place counter offset(0,1)
'----------------------------------------------------------
'
Sub ConditionalsFormattingConvert()
Dim setASName As Worksheet
Dim ASName As String
Dim CopyName As Worksheet
Dim SpCellsConFor As Range
Dim cell As Range
Dim count3 As Long
Dim count50 As Long
'// Sheets Name
Set setASName = ActiveSheet
ASName = setASName.Name
'// Copy Sheet
setASName.Copy setASName
Set CopyName = ActiveSheet
'// Name CopySheet
ActiveSheet.Name = "CopySheet"
'// Conditionals Formatting Cells
Set SpCellsConFor = ActiveCell.SpecialCells _
(xlCellTypeAllFormatConditions)
'//
SpCellsConFor.Select
'// Sub
PasteFC
'// Find Red and green cells
For Each cell In SpCellsConFor
If cell.Interior.ColorIndex = 3 Then
'// Replase with your macro
setASName.Range(cell.Address).Offset(0, 1).Value = _
2 + count3
count3 = count3 + 1
ElseIf cell.Interior.ColorIndex = 50 Then
'// Replase with your macro
setASName.Range(cell.Address).Offset(0, 1).Value = _
22 + count50
count50 = count50 + 1
End If
Next cell
'// Delete CopySheet
Application.DisplayAlerts = False
CopyName.Delete
Application.DisplayAlerts = True
ActiveCell.Select
End Sub
'Conditional format convert (remove)
' if condition is fulfilled
Private Sub PasteFC()
Application.ScreenUpdating = False
Dim rWhole As Range
Dim rCell As Range
Dim ndx As Integer
Dim FCFont As Font
Dim FCBorder As Border
Dim FCInt As Interior
Dim x As Integer
Dim iBorders(3) As Integer
iBorders(0) = xlLeft
iBorders(1) = xlRight
iBorders(2) = xlTop
iBorders(3) = xlBottom
Set rWhole = Selection
For Each rCell In rWhole
rCell.Select
ndx = ActiveCondition(rCell)
If ndx < 0 Then
'Change the Font info
Set FCFont = rCell.FormatConditions(ndx).Font
With rCell.Font
.Bold = NewFC(.Bold, FCFont.Bold)
.Italic = NewFC(.Italic, FCFont.Italic)
.Underline = NewFC(.Underline, FCFont.Underline)
.Strikethrough = NewFC(.Strikethrough, FCFont.Strikethrough)
.ColorIndex = NewFC(.ColorIndex, FCFont.ColorIndex)
End With
'Change the Border Info for each of the 4 types
For x = 0 To 3
Set FCBorder = rCell.FormatConditions(ndx).Borders(iBorders(x))
With rCell.Borders(iBorders(x))
.LineStyle = NewFC(.LineStyle, FCBorder.LineStyle)
.Weight = NewFC(.Weight, FCBorder.Weight)
.ColorIndex = NewFC(.ColorIndex, FCBorder.ColorIndex) '***
End With
Next x
'Change the interior info
Set FCInt = rCell.FormatConditions(ndx).Interior
With rCell.Interior
.ColorIndex = NewFC(.ColorIndex, FCInt.ColorIndex)
.Pattern = NewFC(.Pattern, FCInt.Pattern)
End With
'Delete FC
rCell.FormatConditions.Delete
End If
Next
rWhole.Select
Application.ScreenUpdating = True
MsgBox ("The Formatting based on the Conditions" & vbCrLf & _
"in the range " & rWhole.Address & vbCrLf & _
"has been made standard for those cells" & vbCrLf & _
"and the Conditional Formatting has been removed")
End Sub
Function NewFC(vCurrent As Variant, vNew As Variant)
If IsNull(vNew) Then
NewFC = vCurrent
Else
NewFC = vNew
End If
End Function
Function ActiveCondition(rng As Range) As Integer
'Chip Pearson
http://www.cpearson.com/excel/CFColors.htm
Dim ndx As Long
Dim FC As FormatCondition
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
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
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
--
Best Regards
Joergen Bondesen
"John/Churchwell" wrote in message
...
I have formatted a cell with 3 conditions. What Excel Visual Basic
elements
will let me know which of the 3, if any, conditions were used to format
the
cell.
Bradc