Here's a subroutine which lists the conditional formatting conditions for
every cell on the active sheet on a new sheet at the end of the workbook.
Sub ListCondFmt()
'Declare local variables.
Dim x As Long, Rng As Range, Rx As String, Hits As Long
Dim NewWS As Worksheet, StartWS As Worksheet
Hits& = 1
Set StartWS = ActiveSheet
'Add a new worksheet to the current workbook at the end.
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Set NewWS = ActiveSheet
StartWS.Activate
'Find last (highest row/col) cell used on sheet.
On Error Resume Next
ActiveSheet.UsedRange
LastCell$ = FindLastCell(ActiveSheet)
'If FindLastCell() returned ERROR, set lastCell to A1 (empty sheet?)
If LastCell$ = "ERROR" Then
LastCell$ = "A1"
End If
On Error GoTo LCFerr1
'Select all cells from A1 through the last cell.
ActiveWorkbook.Sheets(ActiveSheet.Name).Range("A1:" & LastCell$).Select
For Each Rng In Selection
If Rng.FormatConditions.Count > 0 Then
Hits& = Hits& + 1
For x = 1 To Rng.FormatConditions.Count
If Rng.FormatConditions(x).Type = 1 Then
Select Case Rng.FormatConditions(x).Operator
Case 1:
Rx$ = "Between " &
Rng.FormatConditions(x).Formula1 & " and " & Rng.FormatConditions(x).Formula2
Case 2:
Rx$ = "Not between " &
Rng.FormatConditions(x).Formula1 & " and " & Rng.FormatConditions(x).Formula2
Case 3:
Rx$ = "Equal to " &
Rng.FormatConditions(x).Formula1
Case 4:
Rx$ = "Not equal to " &
Rng.FormatConditions(x).Formula1
Case 5:
Rx$ = "Greater than " &
Rng.FormatConditions(x).Formula1
Case 6:
Rx$ = "Less than " &
Rng.FormatConditions(x).Formula1
Case 7:
Rx$ = "Greater than or equal to " &
Rng.FormatConditions(x).Formula1
Case 8:
Rx$ = "Less than or equal to " &
Rng.FormatConditions(x).Formula1
Case Else
Rx$ = "Unknown operator " &
Rng.FormatConditions(x).Operator
End Select
ElseIf Rng.FormatConditions(x).Type = 2 Then
Rx$ = Rng.FormatConditions(x).Formula1
Else
Rx$ = "Unknown type"
End If
If x = 1 Then
NewWS.Cells(Hits&, 1).Value = "'" & StartWS.Name
NewWS.Cells(Hits&, 2).Value = "'" & Rng.Address
End If
NewWS.Cells(Hits&, x + 2).Value = "'" & Rx$
Next x
End If
Next Rng
'If no cells were found, tell user & delete the new sheet.
If Hits& = 1 Then
MsgBox "No cells with conditional formatting were found",
vbInformation, "ListCondFmt"
Application.DisplayAlerts = False
NewWS.Delete
Application.DisplayAlerts = True
GoTo Cleanup1
End If
'Add headings for the output rows.
NewWS.Cells(1, 1).Value = "Sheet"
NewWS.Cells(1, 2).Value = "Cell"
NewWS.Cells(1, 3).Value = "Condition1"
NewWS.Cells(1, 4).Value = "Condition2"
NewWS.Cells(1, 5).Value = "Condition3"
'Resize all columns on NewWS.
NewWS.Activate
Cells.Select
Cells.EntireColumn.AutoFit
Cleanup1:
'Free object variables.
Set NewWS = Nothing
Set StartWS = Nothing
'Restore the cursor.
Application.Cursor = xlDefault
Exit Sub
LCFerr1:
If Err.Number <> 0 Then
msg1$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg1$, , "ListCondFmt error", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Sub
Function FindLastCell(Wksht As Worksheet) As String
'Returns address of last cell used (highest row & col) on specified sheet
Dim LastRow As Long
Dim LastCol As Integer
On Error GoTo FLCerr1
With Wksht
LastRow = 0
LastCol = 0
LastRow& = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
LastCol% = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, LookAt:=xlWhole, _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
End With
FindLastCell$ = Cells(LastRow&, LastCol%).AddressLocal
Exit Function
FLCerr1:
FindLastCell$ = "ERROR"
End Function
I know it's a lot of code, but just copy & paste it into a VBA module and
give it a try.
Hope this helps,
Hutch
