Cond Fmt formula export works! But very slow-code alt to SpecialCells?

[BonnieM]

i am so excited that the code below works to export my conditional formatting formulas from huge spreadsheet!

But it is super slow - it's looking through about 2000 cells and returning almost 200 formulas . . . but it takes almost 2 hours to run . . .

I found this link about SpecialCells being the issue and posted my question there, but have not had a response, and I do not understand vba enough yet to craft an alternative.

http://dailydoseofexcel.com/archive...crawl-across-multiple-columns/#comment-842527

Any thoughts from you code angels out there?

Option Explicit


Public Sub ShowConditionalFormatting2()
    
    
    'open new workbook and list all conditional formatting rules.
   
    Dim cf As Variant
    Dim rCell As Range
    Dim colFormats As Collection
    Dim i As Long
    Dim wsOutput As Worksheet
    Dim aOutput() As Variant
    
    Set colFormats = New Collection
    
    For Each rCell In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
        For i = 1 To rCell.FormatConditions.Count
            With rCell.FormatConditions
                On Error Resume Next
                    colFormats.Add .Item(i), CFSignature(.Item(i))
                On Error GoTo 0
            End With
        Next i
    Next rCell
       
    ReDim aOutput(1 To colFormats.Count + 1, 1 To 5)
    
    Set wsOutput = Workbooks.Add.Worksheets(1)
    aOutput(1, 1) = "Type": aOutput(1, 2) = "Range"
    aOutput(1, 3) = "StopIfTrue": aOutput(1, 4) = "Formual1"
    aOutput(1, 5) = "Formual2"
    
    For i = 1 To colFormats.Count
        Set cf = colFormats.Item(i)
           
        aOutput(i + 1, 1) = FCTypeFromIndex(cf.Type)
        aOutput(i + 1, 2) = cf.AppliesTo.Address
        aOutput(i + 1, 3) = cf.StopIfTrue
        On Error Resume Next
            aOutput(i + 1, 4) = "'" & cf.Formula1
            aOutput(i + 1, 5) = "'" & cf.Formula2
        On Error GoTo 0
    Next i
   
    wsOutput.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    wsOutput.UsedRange.EntireColumn.AutoFit
   
    
End Sub

' here’s how I got the type.


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
Public Function CFSignature(ByRef cf As Variant) As String
    
    Dim aReturn(1 To 3) As String
    
    aReturn(1) = cf.AppliesTo.Address
    aReturn(2) = FCTypeFromIndex(cf.Type)
    On Error Resume Next
        aReturn(3) = cf.Formula1
        
    CFSignature = Join(aReturn, vbNullString)
    
End Function

 

[RoryA]

See if this is any faster, per Jeff's suggestion:

Public Sub ShowConditionalFormatting2()
    
    
    'open new workbook and list all conditional formatting rules.
   
    Dim cf As Variant
    Dim rCell As Range
    Dim colFormats As Collection
    Dim i As Long
    Dim wsOutput As Worksheet
    Dim aOutput() As Variant
    Dim rCol As Range
    
    Set colFormats = New Collection
    
    For Each rCol In Sheet1.UsedRange.Columns
        For Each rCell In rCol.SpecialCells(xlCellTypeAllFormatConditions).Cells
            For i = 1 To rCell.FormatConditions.Count
                With rCell.FormatConditions
                    On Error Resume Next
                        colFormats.Add .Item(i), CFSignature(.Item(i))
                    On Error GoTo 0
                End With
            Next i
        Next rCell
    Next rCol
    ReDim aOutput(1 To colFormats.Count + 1, 1 To 5)
    
    Set wsOutput = Workbooks.Add.Worksheets(1)
    aOutput(1, 1) = "Type": aOutput(1, 2) = "Range"
    aOutput(1, 3) = "StopIfTrue": aOutput(1, 4) = "Formual1"
    aOutput(1, 5) = "Formual2"
    
    For i = 1 To colFormats.Count
        Set cf = colFormats.Item(i)
           
        aOutput(i + 1, 1) = FCTypeFromIndex(cf.Type)
        aOutput(i + 1, 2) = cf.AppliesTo.Address
        aOutput(i + 1, 3) = cf.StopIfTrue
        On Error Resume Next
            aOutput(i + 1, 4) = "'" & cf.Formula1
            aOutput(i + 1, 5) = "'" & cf.Formula2
        On Error GoTo 0
    Next i
   
    wsOutput.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    wsOutput.UsedRange.EntireColumn.AutoFit
   
    
End Sub

 

[BonnieM]

Thanks, Rory, (and Jeff?)

I tried that, and got a runtime '1004' error - no cells found

I changed Sheet 1 to ActiveSheet - same error.

 

[RoryA]

Sorry, added a check to ignore any columns that don't have CF in them:

Public Sub ShowConditionalFormatting2()
'open new workbook and list all conditional formatting rules.

    Dim cf                    As Variant
    Dim rCell                 As Range
    Dim rFormats              As Range
    Dim colFormats            As Collection
    Dim i                     As Long
    Dim wsOutput              As Worksheet
    Dim aOutput()             As Variant
    Dim rCol                  As Range

    Set colFormats = New Collection

    For Each rCol In Sheet1.UsedRange.Columns
        On Error Resume Next
        Set rFormats = rCol.SpecialCells(xlCellTypeAllFormatConditions).Cells
        On Error GoTo 0
        If Not rFormats Is Nothing Then
            For Each rCell In rFormats
                For i = 1 To rCell.FormatConditions.Count
                    With rCell.FormatConditions
                        On Error Resume Next
                        colFormats.Add .Item(i), CFSignature(.Item(i))
                        On Error GoTo 0
                    End With
                Next i
            Next rCell
            Set rFormats = Nothing
        End If
    Next rCol
    ReDim aOutput(1 To colFormats.Count + 1, 1 To 5)

    Set wsOutput = Workbooks.Add.Worksheets(1)
    aOutput(1, 1) = "Type": aOutput(1, 2) = "Range"
    aOutput(1, 3) = "StopIfTrue": aOutput(1, 4) = "Formual1"
    aOutput(1, 5) = "Formual2"

    For i = 1 To colFormats.Count
        Set cf = colFormats.Item(i)

        aOutput(i + 1, 1) = FCTypeFromIndex(cf.Type)
        aOutput(i + 1, 2) = cf.AppliesTo.Address
        aOutput(i + 1, 3) = cf.StopIfTrue
        On Error Resume Next
        aOutput(i + 1, 4) = "'" & cf.Formula1
        aOutput(i + 1, 5) = "'" & cf.Formula2
        On Error GoTo 0
    Next i

    wsOutput.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    wsOutput.UsedRange.EntireColumn.AutoFit


End Sub

 

[BonnieM]

OMG - less than 1 minute - you are AMAZING!!! Thank you, THANK YOU!

 

[RoryA]

Glad to help.