Export a list of all conditional formatting to a spreadsheet

[sparky2205]

Folks,
I've spend a considerable amount of time researching this but haven't come up with exactly what I want.
I've found a number of posts which cover it in different ways but I've been unsuccessful in combining different code to achieve what I want.
I want to export a list of all conditional formatting on a worksheet to another workbook.
What I need in the output is:
The Range it applies to
The Type
The formula
StopIfTrue
But also any formatting applied; Bold, Italic, Font Colour, Fill Colour, Border (including colour) etc.

Is it possible to achieve this in a spreadsheet format?

 

[alansidman]

Here is some code that was originally from @shg that may have much of what you are looking for.

Option Explicit

' ============================== S H E E T   M A P =============================
' shg 2010-09, 2010-11, 2013-01

' Creates a sheet map to characterize the contents of each cell with a color,
' and, for non-empty cells, a two-character code

'   Color:
'       Dark Grey   Empty
'       Light Grey  Formula
'       Yellow      A number or date stored as text
'       Red         An error
'       White       None of the above

'   First character => formula or literal:
'       L   A literal
'       F   A formula
'       <   A formula the same as that at left
'       ^   A formula the same as that above
'       +   A formula the same as those above and left

'   Second character => type of value:
'       $   String      (from the type declaration character)
'       @   Currency    (from the type declaration character)
'       #   Double      (from the type declaration character)
'       D   Date
'       E   Error
'       B   Boolean

Sub SheetMap()
    Dim wksInp As Worksheet
    Dim wksOut As Worksheet
    Dim vZoom As Variant
    Dim cell As Range
    Dim avCellType As Variant
    Dim bSU As Boolean
    Dim iCalc As XlCalculation
    Dim sWks As String

    With Application
        bSU = .ScreenUpdating
        .ScreenUpdating = False
        iCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    Set wksInp = ActiveSheet
    vZoom = ActiveWindow.Zoom

    sWks = "Formula map for " & wksInp.Name
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWks).Delete
    Application.DisplayAlerts = True

    ActiveWorkbook.Worksheets.Add(After:=wksInp).Name = sWks
    Set wksOut = ActiveSheet
    ActiveWindow.Zoom = vZoom
    wksOut.Cells.Interior.Color = RGB(144, 144, 144)

    For Each cell In wksInp.UsedRange
        avCellType = CellType(cell)
        With wksOut.Range(cell.Address)
            .Value = avCellType(0)
            .Interior.Color = avCellType(1)
        End With
    Next cell

    #If True Then
        wksInp.Rows(1).Copy
        wksOut.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    #Else
        wksOut.Columns.AutoFit
    #End If

    With Application
        .ScreenUpdating = bSU
        .Calculation = iCalc
    End With
End Sub

Function CellType(r As Range) As Variant
    Dim sTyp As String
    Dim iCol As Long
    Dim iCase As Long
    Dim sFrm As String

    With r(1)
        If .HasFormula Then
            sFrm = .FormulaR1C1

            If .Column > 1 Then
                If .Offset(0, -1).FormulaR1C1 = sFrm Then iCase = iCase + 1
            End If

            If .Row > 1 Then
                If .Offset(-1, 0).FormulaR1C1 = sFrm Then iCase = iCase + 2
            End If

            sTyp = Mid("F<^+", iCase + 1, 1)
            iCol = RGB(229, 229, 229)
        Else
            sTyp = "L"
            iCol = vbWhite
        End If

        Select Case VarType(.Value)
        Case vbEmpty
            sTyp = vbNullString
            iCol = RGB(144, 144, 144)
        Case vbDouble
            sTyp = sTyp & "#"
        Case vbString
            If IsNumeric(.Value2) Then
                sTyp = sTyp & "#"
                iCol = vbYellow
            ElseIf IsDate(.Value2) Then
                sTyp = sTyp & "D"
                iCol = vbYellow
            Else
                sTyp = sTyp & "$"
            End If
        Case vbCurrency
            sTyp = sTyp & "@"
        Case vbDate
            sTyp = sTyp & "D"
        Case vbError
            sTyp = sTyp & "E"
            iCol = vbRed
        Case vbBoolean
            sTyp = sTyp & "B"
        Case Else
            Stop    ' that would be a problem
        End Select
    End With

    CellType = Array(sTyp, iCol)
End Function

 

[Fluff]

Have you seen this Listing Format Conditions – Daily Dose of Excel

 

[sparky2205]

Thanks for the responses guys.

@alansidman
This code produces a sheet map that shows formulas and data types etc. in the worksheet. Unfortunately it doesn't look at conditional formatting.

@Fluff
I did see that post. It tells me what cells have conditional formatting, what are the dependent cells and what the formula in the cells is.
What it doesn't tell me is what formatting is applied to each range of cells where the rule is true. i.e. font colour, fill colour, border colour, etc.

 

[Fluff]

I've discovered that with 365 you can loop through the format conditions, rather than having to loop through the actual cells like

Sub sparky()
   Dim i As Long
   With ActiveSheet.Cells.FormatConditions
   For i = 1 To .Count
      Sheets("Sheet1").Cells(i + 1, 1) = .Item(i).AppliesTo.Address
      Sheets("Sheet1").Cells(i + 1, 2) = FCTypeFromIndex(.Item(i).Type)
      Sheets("Sheet1").Cells(i + 1, 3) = "'" & .Item(i).Formula1
      Sheets("Sheet1").Cells(i + 1, 4) = .Item(i).StopIfTrue
      Sheets("Sheet1").Cells(i + 1, 5) = .Item(i).Interior.Color
   Next i
   End With
End Sub

This uses the Function from the link I provided to get the format condition type.

 

[sparky2205]

Fluff,
this works really well and generates a list of all the cells with conditional formatting with the related formula, the StopIfTrue value and the interior colour.
I've added a couple of lines to your code for some of the other formats I'm using:

Sheets("Sheet1").Cells(i + 1, 6) = .Item(i).Font.Color
Sheets("Sheet1").Cells(i + 1, 7) = .Item(i).Font.Italic
Sheets("Sheet1").Cells(i + 1, 8) = .Item(i).Font.Bold
Sheets("Sheet1").Cells(i + 1, 9) = .Item(i).Borders.Color

All working well.
Thanks as usual for your help.

 

[Fluff]

Glad we could help & thanks for the feedback.