Option Explicit
Sub ShowConditionalFormatting()
'unprotect and unfilter the active sheet
With ActiveSheet
ActiveSheet.Unprotect Password:="icrr"
If .FilterMode Then
.ShowAllData
End If
End With
Dim aResult() As Variant
Dim sRange As String
Dim cf As Variant
Dim rCell As Range
Dim colFormats As Collection
Dim i As Long
Dim wsOutput As Worksheet
Application.ScreenUpdating = False
Set colFormats = New Collection
'Modify here to select the desired range
'Useful when conditional formatting is applied to huge ranges and
'you only want to see the conditional formats for the used range
'or any other user specified range
sRange = ActiveSheet.Range("A6:AA6").CurrentRegion.Address
For Each rCell In ActiveSheet.Range(sRange).SpecialCells(xlCellTypeAllFormatConditions).Cells
For i = 1 To rCell.FormatConditions.Count
On Error Resume Next
'Modified to let everything through
colFormats.Add rCell.FormatConditions.Item(i), rCell.FormatConditions(i).AppliesTo.Address
On Error GoTo 0
Next i
Next rCell
'Headers for the output IT DID CREATE A NEW WORKBOOK WITH THE HEADERS
Set wsOutput = Workbooks.Add.Worksheets(1)
wsOutput.Range("A1:E1").Value = Array("Type", "Range", "StopIfTrue", "Formual1", "Formual2")
'Extract range and filter
wsOutput.Range("J1:N1").Value = Array("Type", "Range", "StopIfTrue", "Formual1", "Formual2")
wsOutput.Range("H1").Value = "StopIfTrue"
'I'M NOT SURE WHAT SHOULD GO BETWEEN THE QUOTES BELOW?
wsOutput.Range("H2").Value = "Not Sure"
'Resize the Variant range and grab the headers
sRange = Range("A1").Resize(colFormats.Count + 1, 5).Address
aResult() = Range(sRange).Value
'Move data from the collection into the variant.
'Instead of writing cell by cell, the complete array is written at the same speed as writing one cell
For i = 1 To colFormats.Count
Debug.Print i
Set cf = colFormats(i)
aResult(i + 1, 1) = FCTypeFromIndex(cf.Type)
aResult(i + 1, 2) = cf.AppliesTo.Address
aResult(i + 1, 3) = cf.StopIfTrue
On Error Resume Next
'I'M NOT SURE WHAT SHOULD GO BETWEEN THE QUOTES BELOW?
aResult(i + 1, 4) = "what goes here" & cf.Formula1
aResult(i + 1, 5) = "and Here" & cf.Formula2
On Error GoTo 0
Next i
'Write the result
Range(sRange).Value = aResult()
'Filter And extract
Range(sRange).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Range("H1:H2"), _
CopyToRange:=Range("J1:N1"), _
Unique:=True
'Delete the redundant data from the variant
ActiveSheet.Range("A:I").Delete
wsOutput.Range("A1").CurrentRegion.EntireColumn.AutoFit
Erase aResult
Application.ScreenUpdating = False
'reprotect the active sheet, allowing filtering and pivot tables
ActiveSheet.Protect Password:="icrr", _
DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub
Function FCTypeFromIndex(lIndex As Long) As String
Select Case lIndex
Case 12: FCTypeFromIndex = "Above Average"
Case 10: FCTypeFromIndex = "Blanks"
Case 1: FCTypeFromIndex = "Cell Value"
Case 3: FCTypeFromIndex = "Color Scale"
Case 4: FCTypeFromIndex = "DataBar"
Case 16: FCTypeFromIndex = "Errors"
Case 2: FCTypeFromIndex = "Expression"
Case 6: FCTypeFromIndex = "Icon Sets"
Case 14: FCTypeFromIndex = "No Blanks"
Case 17: FCTypeFromIndex = "No Errors"
Case 9: FCTypeFromIndex = "Text"
Case 11: FCTypeFromIndex = "Time Period"
Case 5: FCTypeFromIndex = "Top 10?"
Case 8: FCTypeFromIndex = "Unique Values"
Case Else: FCTypeFromIndex = "Unknown"
End Select
End Function