none
VBA: List all conditional formats in a sheet RRS feed

  • Question

  • Hi,

    I found some code on the internet to list all conditional formats and modified it a bit to add additional information.

    http://dailydoseofexcel.com/archives...comment-399333

    Everything works fine except for 2 CF types: Unique Values & IconSets.

    The unique value method as a formatcondition DupeUnique but I am not able to read it out. Error:="The object invoked has disconnected from its clients."

    All other types are working, e.g. for the databar type, I can get the rank or the operator for type 1, ...

    I have a workaround in mind but would like to know why it is not working for both types. Hope I am clear enough.

    Full code:

    Option Explicit
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : FCTypeFromIndex
    ''' Author ©   : Dick Kusleika
    ''' Date       : 30/06/2018
    '''---------------------------------------------------------------------------------------
    Private 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 13:    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
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : ShowConditionalFormatting
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 30/06/2018
    '''---------------------------------------------------------------------------------------
    Sub ShowConditionalFormatting()
       Dim varConFor        As Variant
       Dim rngCell          As Range
       Dim colFormats       As Collection
       Dim lngI             As Long
       Dim objOutput        As Worksheet
       Dim objWsh           As Worksheet
       Dim lngPos           As Long
       Dim objSource        As Workbook
       Dim fc As FormatCondition
       Set objSource = ActiveWorkbook
       
       ''' Prepare the output
       Set objOutput = Workbooks.Add.Worksheets(1)
       With objOutput.Cells(1, 1)
          .Value = "Workbook:"
          .Font.Size = 14
          .Font.Color = 16777215
          .Interior.Color = 3506772
       End With
       
       With objOutput.Cells(2, 1)
          .Value = "Date:"
          .Font.Size = 14
          .Font.Color = 16777215
          .Interior.Color = 3506772
       End With
       
       With objOutput
          .Cells(1, 2) = ActiveWorkbook.Name
          .Cells(2, 2) = Date
       End With
       
       lngPos = 4
       
       For Each objWsh In objSource.Worksheets
          Set colFormats = New Collection
          On Error Resume Next
          lngI = 0
          lngI = objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells.CountLarge
          On Error GoTo 0
          If lngI > 0 Then
             For Each rngCell In objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
                For lngI = 1 To rngCell.FormatConditions.Count
                   On Error Resume Next
                   colFormats.Add rngCell.FormatConditions.Item(lngI), rngCell.FormatConditions(lngI).AppliesTo.Address & "_" & lngI
                   On Error GoTo 0
                Next lngI
             Next rngCell
          End If
          
          With objOutput
             .Range(Cells(lngPos, 2), Cells(lngPos, 8)) = Array("Type", "Range", "StopIfTrue", "Operator", "Formual1", "Formual2", "Color")
             .Cells(lngPos, 1) = objWsh.Name
             .Range(Cells(lngPos, 1), Cells(lngPos, 8)).Font.Size = 14
             .Range(Cells(lngPos, 1), Cells(lngPos, 8)).Font.Color = 16777215
             .Range(Cells(lngPos, 1), Cells(lngPos, 8)).Interior.Color = 3506772
          End With
          
          If colFormats.Count > 0 Then
             For lngI = 1 To colFormats.Count
                Set varConFor = colFormats(lngI)
          
                With objOutput.Cells(lngPos + lngI + 1, 2)
                   .Value = FCTypeFromIndex(varConFor.Type)
                   .Offset(0, 1).Value = varConFor.AppliesTo.Address
                   .Offset(0, 2).Value = varConFor.StopIfTrue
                   On Error Resume Next
                   Select Case varConFor.Type
                      Case 1:
                         .Offset(0, 3).Value = CFOperator(varConFor.Operator)
                         .Offset(0, 4).Value = varConFor.Formula1
                         .Offset(0, 5).Value = varConFor.Formula2
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 2:
                         .Offset(0, 4).Value = "'" & varConFor.Formula1
                         .Offset(0, 5).Value = "'" & varConFor.Formula2
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 3:
                         .Offset(0, 4).Value = "'" & varConFor.ColorScaleCriteria(1).Value
                         .Offset(0, 5).Value = "'" & varConFor.ColorScaleCriteria(2).Value
                         .Offset(0, 6).Interior.Color = varConFor.ColorScaleCriteria(1).FormatColor.Color
                      Case 4:
                         .Offset(0, 6).Interior.Color = varConFor.BarColor.Color
                      Case 5:
                         .Offset(0, 4).Value = varConFor.Rank
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 6: Stop
                         '.Offset(0, 4).Value = varConFor.Rank
                      Case 7:
                      Case 8: Stop
                         'With objSource.objWsh
                         '   Set rngCell = .Range("$A$1:$A$10")
                         'End With
                         Stop
                         'workbooks("CF_Dev.xlsm").Sheets("sheet1").range("A1:A10").formatconditions(1).dupeunique
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 9:
                         .Offset(0, 3).Value = CFTextOperator(varConFor.TextOperator)
                         .Offset(0, 4).Value = Left(Mid(varConFor.Formula1, InStr(varConFor.Formula1, Chr(34)) + 1), InStr(Mid(varConFor.Formula1, InStr(varConFor.Formula1, Chr(34)) + 1), Chr(34)) - 1)
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 10:
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 11:
                         .Offset(0, 3).Value = CFDateOperator(varConFor.DateOperator)
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 12:
                         .Offset(0, 3).Value = CFAboveAverage(varConFor.AboveBelow)
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 13:
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 14:
                      Case 15:
                      Case 16:
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case 17:
                         .Offset(0, 6).Interior.Color = varConFor.Interior.Color
                      Case Else
                   End Select
                   
                   
                   On Error GoTo 0
                End With
             Next lngI
             lngPos = lngPos + lngI + 2
          Else
             'Stop
             objOutput.Cells(lngPos + 2, 1) = "No conditional formats in sheet"
             lngPos = lngPos + 4
          End If
       Next objWsh
       
       objOutput.UsedRange.EntireColumn.AutoFit
       Set colFormats = Nothing
       Set objOutput = Nothing
       Set objWsh = Nothing
       Set objSource = Nothing
    End Sub
    
    Private Function CFOperator(xloperator As Long) As String
       Select Case xloperator
          Case xlBetween:         CFOperator = "Between"
          Case xlNotBetween:      CFOperator = "Not Between"
          Case xlEqual:           CFOperator = "Equal"
          Case xlNotEqual:        CFOperator = "Not Equal"
          Case xlGreater:         CFOperator = "Greater"
          Case xlLess:            CFOperator = "Less"
          Case xlGreaterEqual:    CFOperator = "Greater or Equal"
          Case xlLessEqual:       CFOperator = "Less or Equal"
       End Select
    End Function
    
    Private Function CFTextOperator(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFTextOperator = "Contains"
          Case 1:                 CFTextOperator = "Does not contain"
          Case 2:                 CFTextOperator = "Begins with"
          Case 3:                 CFTextOperator = "Ends with"
       End Select
    End Function
    
    Private Function CFAboveAverage(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFAboveAverage = "Above Avg"
          Case 1:                 CFAboveAverage = "Below Avg"
          Case 2:                 CFAboveAverage = "Equal or Above Avg"
          Case 3:                 CFAboveAverage = "Equal or Below Avg"
          Case 4:                 CFAboveAverage = "Above Std Dev"
          Case 5:                 CFAboveAverage = "Below Std Dev"
          Case Else:              CFAboveAverage = "Unknown"
       End Select
    End Function
    
    Private Function CFDateOperator(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFDateOperator = "Today"
          Case 1:                 CFDateOperator = "Yesterday"
          Case 2:                 CFDateOperator = "Last 7 days"
          Case 3:                 CFDateOperator = "This Week"
          Case 4:                 CFDateOperator = "Last Week"
          Case 5:                 CFDateOperator = "Last Month"
          Case 6:                 CFDateOperator = "Tomorrow"
          Case 7:                 CFDateOperator = "Next Week"
          Case 8:                 CFDateOperator = "Next Month"
          Case 9:                 CFDateOperator = "This Month"
          Case Else:              CFDateOperator = "Unknown"
       End Select
    End Function

    Monday, July 2, 2018 4:23 PM

Answers

  • Hi JP,

    Based on the investigation, the DupeUnique property required the worksheet of the cell is active before we can read it. The code work well after I add the code like below: 

    Case 8:
           Workbooks("CF_Dev.xlsm").Activate
           .Offset(0, 3) = varConFor.DupeUnique
           .Offset(0, 6).Interior.Color = varConFor.Interior.Color

    Please feel free to let me know if you still have the problem.

    Regards & Fei



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by JP Ronse Wednesday, July 4, 2018 3:05 PM
    Wednesday, July 4, 2018 8:32 AM
    Moderator
  • As Fei Xue suggests ensure the workbook is active, which with your code you can do after adding the new workbook with objSource.Activate.

    Then if writing to cells in what's now not the active sheet qualify Cells to the sheet with a dot .Cells

     With objOutput
             .Range(.Cells(lngPos, 2), etc

    • Marked as answer by JP Ronse Wednesday, July 4, 2018 3:05 PM
    Wednesday, July 4, 2018 9:15 AM
    Moderator

All replies

  • Hi JP Ronse,

    I am trying to reproduce this issue however failed. Here is the screenshot for your reference:

    Would you mind sharing the detail steps or a demo spreadsheet to help us understanding this issue?

    Regards & Fei


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, July 3, 2018 7:29 AM
    Moderator
  • Hi Fei,

    You can download the workbook from my onedrive: https://1drv.ms/x/s!AmIR8Z3XdrKRh1fLncHOOAWRB5yS

    If you run the Demo macro in module 2 you will see that DupeUnique can be used to determine the subtype unique or duplicate values.

    If you run ShowConditionalFormatting in module 1, an error will pop up.

    But basically it is just the same code, so why can I access DupeUnique if I use the direct method and not when it is stored in a collection.

    Almost the same issue occurs when an iconset is used.

    Regards,

    JP

    Tuesday, July 3, 2018 4:44 PM
  • Hi JP,

    Based on the investigation, the DupeUnique property required the worksheet of the cell is active before we can read it. The code work well after I add the code like below: 

    Case 8:
           Workbooks("CF_Dev.xlsm").Activate
           .Offset(0, 3) = varConFor.DupeUnique
           .Offset(0, 6).Interior.Color = varConFor.Interior.Color

    Please feel free to let me know if you still have the problem.

    Regards & Fei



    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by JP Ronse Wednesday, July 4, 2018 3:05 PM
    Wednesday, July 4, 2018 8:32 AM
    Moderator
  • As Fei Xue suggests ensure the workbook is active, which with your code you can do after adding the new workbook with objSource.Activate.

    Then if writing to cells in what's now not the active sheet qualify Cells to the sheet with a dot .Cells

     With objOutput
             .Range(.Cells(lngPos, 2), etc

    • Marked as answer by JP Ronse Wednesday, July 4, 2018 3:05 PM
    Wednesday, July 4, 2018 9:15 AM
    Moderator
  • Hi Fei, Peter,

    Thanks for your input. Not the answer that makes me happy but at least I know now why I couldn't read this parameter and good tip to qualify the cells.

    But this doesn't solve the issue for 100%, even when the workbook is active it does not always work when the sheet contains multiple CF's of this type. I think that the cell must also be the active one.

    I started rewriting the code to use a class module with all properties I need and put that in a collection for output. With this method I can collect the data during the analysis of the CF.

    Regards,

    JP

    Wednesday, July 4, 2018 3:04 PM
  • But this doesn't solve the issue for 100%,

    Maybe you could upload an example that illustrates what's not solved
    Thursday, July 5, 2018 9:17 AM
    Moderator
  • Hi Peter,

    Maybe I post this twice, thought I did reply but don't see appearing.

    I could get it working. The remaining issue had that not all types were reported. Say, I had a range for unique values and another range for duplicate values, only one type was reported and some times none of both. Or it went wrong when I ran the code but was OK when I walked though with F8.

    I rewrote the code to activate each sheet and report een CF area immediately. Looks as this solved it.

    Regards,

    JP

    Revised code:

    Option Explicit
    Option Private Module
    
    Private mlngPos As Long
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : CFAboveAverage
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Private Function CFAboveAverage(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFAboveAverage = "Above Avg"
          Case 1:                 CFAboveAverage = "Below Avg"
          Case 2:                 CFAboveAverage = "Equal or Above Avg"
          Case 3:                 CFAboveAverage = "Equal or Below Avg"
          Case 4:                 CFAboveAverage = "Above Std Dev"
          Case 5:                 CFAboveAverage = "Below Std Dev"
          Case Else:              CFAboveAverage = "Unknown"
       End Select
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : CFDateOperator
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Private Function CFDateOperator(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFDateOperator = "Today"
          Case 1:                 CFDateOperator = "Yesterday"
          Case 2:                 CFDateOperator = "Last 7 days"
          Case 3:                 CFDateOperator = "This Week"
          Case 4:                 CFDateOperator = "Last Week"
          Case 5:                 CFDateOperator = "Last Month"
          Case 6:                 CFDateOperator = "Tomorrow"
          Case 7:                 CFDateOperator = "Next Week"
          Case 8:                 CFDateOperator = "Next Month"
          Case 9:                 CFDateOperator = "This Month"
          Case Else:              CFDateOperator = "Unknown"
       End Select
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : CFOperator
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Private Function CFOperator(xloperator As Long) As String
       Select Case xloperator
          Case xlBetween:         CFOperator = "Between"
          Case xlNotBetween:      CFOperator = "Not Between"
          Case xlEqual:           CFOperator = "Equal"
          Case xlNotEqual:        CFOperator = "Not Equal"
          Case xlGreater:         CFOperator = "Greater"
          Case xlLess:            CFOperator = "Less"
          Case xlGreaterEqual:    CFOperator = "Greater or Equal"
          Case xlLessEqual:       CFOperator = "Less or Equal"
       End Select
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : CFTextOperator
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Private Function CFTextOperator(xloperator As Long) As String
       Select Case xloperator
          Case 0:                 CFTextOperator = "Contains"
          Case 1:                 CFTextOperator = "Does not contain"
          Case 2:                 CFTextOperator = "Begins with"
          Case 3:                 CFTextOperator = "Ends with"
       End Select
    End Function
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : DeleteCFSheet
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Sub DeleteCFSheet()
       On Error Resume Next
       ActiveSheet.Cells.SpecialCells(xlCellTypeAllFormatConditions).FormatConditions.Delete
       On Error GoTo 0
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : DeleteCFWorkbook
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Sub DeleteCFWorkbook()
       Dim objWsh  As Worksheet
       
       On Error Resume Next
       For Each objWsh In ActiveWorkbook.Worksheets
          objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).FormatConditions.Delete
       Next objWsh
       On Error GoTo 0
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : FCTypeFromIndex
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 30/06/2018
    '''---------------------------------------------------------------------------------------
    Private 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 13:    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
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : ShowConditionalFormatting
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 30/06/2018
    '''---------------------------------------------------------------------------------------
    Sub ShowConditionalFormatting()
       Dim rngCell          As Range
       Dim lngI             As Long
       Dim objOutput        As Worksheet
       Dim objWsh           As Worksheet
       Dim objSource        As Workbook
       Dim intArea          As Integer
       
       Application.ScreenUpdating = False
       
       Set objSource = ActiveWorkbook
       
       ''' Prepare the output
       Set objOutput = Workbooks.Add.Worksheets(1)
       With objOutput.Cells(1, 1)
          .Value = "Workbook:"
          .Font.Size = 14
          .Font.Color = 16777215
          .Interior.Color = 3506772
       End With
       
       With objOutput.Cells(2, 1)
          .Value = "Date:"
          .Font.Size = 14
          .Font.Color = 16777215
          .Interior.Color = 3506772
       End With
       
       With objOutput
          .Cells(1, 2) = ActiveWorkbook.Name
          .Cells(2, 2) = Date
       End With
       
       mlngPos = 4
       
       objSource.Activate
       For Each objWsh In objSource.Worksheets
          Application.StatusBar = "Analysing sheet: " & objWsh.Name
          If mlngPos > 4 Then mlngPos = objOutput.Cells(Rows.Count, 2).End(xlUp).Row + 2
          With objOutput
             .Range(.Cells(mlngPos, 2), .Cells(mlngPos, 8)) = Array("Type", "Range", "StopIfTrue", "Operator", "Formual1", "Formual2", "Color")
             .Cells(mlngPos, 1) = objWsh.Name
             .Range(.Cells(mlngPos, 1), .Cells(mlngPos, 8)).Font.Size = 14
             .Range(.Cells(mlngPos, 1), .Cells(mlngPos, 8)).Font.Color = 16777215
             .Range(.Cells(mlngPos, 1), .Cells(mlngPos, 8)).Interior.Color = 3506772
          End With
          objWsh.Activate
          On Error Resume Next
          lngI = 0
          lngI = objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells.CountLarge
          On Error GoTo 0
          If lngI > 0 Then
             For intArea = 1 To objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Areas.Count
                Set rngCell = objWsh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Areas(intArea)
                WriteOutput objOutput, rngCell
             Next intArea
          Else
             Set rngCell = Nothing
             WriteOutput objOutput, rngCell
          End If
       Next objWsh
       
       objOutput.UsedRange.EntireColumn.AutoFit
       objOutput.Activate
       Set objOutput = Nothing
       Set objWsh = Nothing
       Set objSource = Nothing
       Application.StatusBar = False
       Application.ScreenUpdating = True
    End Sub
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : WriteOutput
    ''' Author ©   : Jean-Pierre Degroote
    ''' Date       : 05/07/2018
    '''---------------------------------------------------------------------------------------
    Sub WriteOutput(objOutput As Worksheet, rngCell As Range)
       Dim lngI       As Long
       
       mlngPos = objOutput.Cells(Rows.Count, 2).End(xlUp).Row
       If objOutput.Cells(mlngPos, 2) = "Type" Then mlngPos = mlngPos + 1
       If Not rngCell Is Nothing Then
          For lngI = 1 To rngCell.FormatConditions.Count
             With objOutput.Cells(mlngPos + lngI, 2)
                .Value = FCTypeFromIndex(rngCell.FormatConditions(lngI).Type)
                .Offset(0, 1).Value = rngCell.FormatConditions(lngI).AppliesTo.Address
                .Offset(0, 2).Value = rngCell.FormatConditions(lngI).StopIfTrue
                On Error Resume Next
                Select Case rngCell.FormatConditions(lngI).Type
                   Case 1:
                      .Offset(0, 3).Value = CFOperator(rngCell.FormatConditions(lngI).Operator)
                      .Offset(0, 4).Value = rngCell.FormatConditions(lngI).Formula1
                      .Offset(0, 5).Value = rngCell.FormatConditions(lngI).Formula2
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 2:
                      .Offset(0, 4).Value = "'" & rngCell.FormatConditions(lngI).Formula1
                      .Offset(0, 5).Value = "'" & rngCell.FormatConditions(lngI).Formula2
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 3:
                      .Offset(0, 4).Value = "'" & rngCell.FormatConditions(lngI).ColorScaleCriteria(1).Value
                      .Offset(0, 5).Value = "'" & rngCell.FormatConditions(lngI).ColorScaleCriteria(2).Value
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).ColorScaleCriteria(1).FormatColor.Color
                   Case 4:
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).BarColor.Color
                   Case 5:
                      .Offset(0, 4).Value = rngCell.FormatConditions(lngI).Rank
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 6:
                      '.Offset(0, 3).Value = rngCell.FormatConditions(lngI).IconCriteria(1).Operator
                      '.Offset(0, 4).Value = rngCell.FormatConditions(lngI).IconCriteria(1).Value
                      '.Offset(0, 5).Value = rngCell.FormatConditions(lngI).IconCriteria(2).Value
                   Case 7:
                   Case 8:
                      .Offset(0, 3).Value = IIf(rngCell.FormatConditions(lngI).DupeUnique = 0, "Unique", "Duplicates")
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 9:
                      .Offset(0, 3).Value = CFTextOperator(rngCell.FormatConditions(lngI).TextOperator)
                      .Offset(0, 4).Value = Left(Mid(rngCell.FormatConditions(lngI).Formula1, InStr(rngCell.FormatConditions(lngI).Formula1, Chr(34)) + 1), InStr(Mid(rngCell.FormatConditions(lngI).Formula1, InStr(rngCell.FormatConditions(lngI).Formula1, Chr(34)) + 1), Chr(34)) - 1)
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 10:
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 11:
                      .Offset(0, 3).Value = CFDateOperator(rngCell.FormatConditions(lngI).DateOperator)
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 12:
                      .Offset(0, 3).Value = CFAboveAverage(rngCell.FormatConditions(lngI).AboveBelow)
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 13:
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 14:
                   Case 15:
                   Case 16:
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case 17:
                      .Offset(0, 6).Interior.Color = rngCell.FormatConditions(lngI).Interior.Color
                   Case Else
                End Select
                On Error GoTo 0
             End With
          Next lngI
          
       Else
          objOutput.Cells(mlngPos + 1, 1) = "No conditional formats in sheet"
       End If
    End Sub

    Thursday, July 5, 2018 4:25 PM