Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 24

Thread: Listing Conditional Formatting on Separate Sheet or Workbook

  1. #1
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location

    Listing Conditional Formatting on Separate Sheet or Workbook

    Listing Conditional Formatting on Separate Sheet or Workbook:

    I have found the impressive looking code below, written by Dick Kusleika, and tried to use it for my purposes. The code was written to list the first and second conditional formatting conditions, but only managed to list all the first conditions in my case. (I use Excel 2010).

    I would like to get it to work for the second condition, as well as third conditions if possible, but I don't have a clue of how to fix it.
    I would really like to list all 3 conditions (all conditions are expressions).

    Even if it can only be done for a single cell at a time (i.e. no counting required), it would be of great assistance.


    I have attached an example of the type of conditional formatting I have, as well as the output of the code below. Note that only the first condition is listed.

    Original code by Dick Kusleika at the following url:

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

    Any help would be greatly appreciated.


    Sub ShowConditionalFormatting()
       
        Dim cf As Variant
        Dim rCell As Range
        Dim colFormats As Collection
        Dim i As Long
        Dim wsOutput As Worksheet
       
        Set colFormats = New Collection
       
        For Each rCell In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
            For i = 1 To rCell.FormatConditions.Count
                On Error Resume Next
                    colFormats.Add rCell.FormatConditions.Item(i), rCell.FormatConditions(i).AppliesTo.Address
                On Error GoTo 0
            Next i
        Next rCell
           
        Set wsOutput = Workbooks.Add.Worksheets(1)
        wsOutput.Range("A1:E1").Value = Array("Type", "Range", "StopIfTrue", "Formual1", "Formual2")
       
        For i = 1 To colFormats.Count
            Set cf = colFormats(i)
           
            With wsOutput.Cells(i + 1, 1)
                .Value = FCTypeFromIndex(cf.Type)
                .Offset(0, 1).Value = cf.AppliesTo.Address
                .Offset(0, 2).Value = cf.StopIfTrue
                On Error Resume Next
                    .Offset(0, 3).Value = "'" & cf.Formula1
                    .Offset(0, 4).Value = "'" & cf.Formula2
                On Error GoTo 0
            End With
        Next i
       
        wsOutput.UsedRange.EntireColumn.AutoFit
       
    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





    Thank you very much,
    Regards,
    vanhunk
    Attached Images Attached Images
    Attached Files Attached Files

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    The problem is that he is using the cell address as the collection key, so the second one overwrites the first, easily overcome.

    Sub ShowConditionalFormatting()
         
        Dim cf As Variant
        Dim rCell As Range
        Dim colFormats As Collection
        Dim i As Long
        Dim wsOutput As Worksheet
         
        Set colFormats = New Collection
         
        For Each rCell In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
            For i = 1 To rCell.FormatConditions.Count
                On Error Resume Next
                colFormats.Add rCell.FormatConditions.Item(i), CStr(i) & "-" & rCell.FormatConditions(i).AppliesTo.Address
                On Error GoTo 0
            Next i
        Next rCell
         
        Set wsOutput = Workbooks.Add.Worksheets(1)
        wsOutput.Range("A1:E1").Value = Array("Type", "Range", "StopIfTrue", "Formual1", "Formual2")
         
        For i = 1 To colFormats.Count
        
            Set cf = colFormats(i)
             
            With wsOutput.Cells(i + 1, 1)
                .Value = FCTypeFromIndex(cf.Type)
                .Offset(0, 1).Value = cf.AppliesTo.Address
                .Offset(0, 2).Value = cf.StopIfTrue
                On Error Resume Next
                .Offset(0, 3).Value = "'" & cf.Formula1
                .Offset(0, 4).Value = "'" & cf.Formula2
                On Error GoTo 0
            End With
        Next i
         
        wsOutput.UsedRange.EntireColumn.AutoFit
    End Sub
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    I'd suggest:

    Sub ShowConditionalFormatting()
        On Error Resume Next
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|")
        ReDim sn(Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Count *3)
             
        For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            For Each cf In cl.FormatConditions
                x4 = ""
                x4 = cf.Formula1
                x5 = ""
                x5 = cf.Formula2
                sn(y) = Array(cf.Type, sp(cf.Type), cf.AppliesTo.Address, cf.StopIfTrue, x4, x5)
                y = y + 1
            Next
        Next
         
        With ThisWorkbook.Sheets.Add
              .Range("A1:F1").Value = Split("Type|Typename|Range|StopIfTrue|Formula1|Formula2", "|")
              For j = 0 To y
                 .Cells(2 + j, 1).Resize(, 6) = sn(j)
               Next
        End With
    End Sub

  4. #4
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Hi snb,

    The result I got is not what I am looking for. It does not show the formulas. See below:

    Type Typename Range StopIfTrue Formula1 Formula2
    2 Color Scale $E$59:$P$59 TRUE 0
    2 Color Scale $E$59:$P$59 TRUE 0

    The code provided by xld does the trick, except for listing everything under each other instead of splitting the formulas into columns. See below:
    Type Range StopIfTrue Formual1 Formual2
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>=7)*(E60<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>$D60)*(E60<>"")

    Thanks you very much and have a nice day.

    Regards,
    vanhunk

  5. #5
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Thank you xld,

    This does the trick. The only thing that still needs to be changed is how the results are listed. The results of formula 1, formula 2, and formula 3 is listed underneath each other, instead of next to each other. See results below:
    Type Range StopIfTrue Formual1 Formual2
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>=7)*(E60<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>$D60)*(E60<>"")

    Thank you very much, this is awesome!
    Regards,
    vanhunk

  6. #6
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Only 2 minor amendments:

    Sub M_snb()
        On Error Resume Next
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|")
        ReDim sn(Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Count * 3)
        
        For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions)
            For Each cf In cl.FormatConditions
                x4 = ""
                x4 = cf.Formula1
                x5 = ""
                x5 = cf.Formula2
                sn(y) = Array(cf.Type, sp(cf.Type), cf.AppliesTo.Address, cf.StopIfTrue, "'" & x4, "'" & x5)
                y = y + 1
            Next
        Next
         
        With ThisWorkbook.Sheets.Add
            .Range("A1:F1").Value = Split("Type|Typename|Range|StopIfTrue|Formula1|Formula2", "|")
            For j = 0 To y
                .Cells(2 + j, 1).Resize(, 6) = sn(j)
            Next
        End With
    End Sub

  7. #7
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Hi snb,
    It seems like it is duplicating the formulas for every cell in the range. For example, instead of only have 3 lines for range E59:P59, one for each formula, it now has many. See below:
    Type Typename Range StopIfTrue Formula1
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")

    Instead of:
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    Expression $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    Expression $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"")

    Thanks!

    Regards,
    vanhunk

  8. #8
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    No problem:

    Sub M_snb()
        On Error Resume Next
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|")
        
        With CreateObject("scripting.dictionary")
            .Item("titel") = Split("Type|Typename|Range|StopIfTrue|Formula1|Formula2", "|")
            For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions)
                For Each cf In cl.FormatConditions
                    x4 = ""
                    x4 = cf.Formula1
                    x5 = ""
                    x5 = cf.Formula2
                    .Item(cf.AppliesTo.Address & x4) = Array(cf.Type, sp(cf.Type), cf.AppliesTo.Address, cf.StopIfTrue, "'" & x4, "'" & x5)
                Next
            Next
            sn = Application.Index(.items, 0, 0)
        End With
        
        With ThisWorkbook.Sheets.Add
            .Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
        End With
    End Sub

  9. #9
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Hi snb,
    It now looks like this:
    Type Typename Range StopIfTrue Formula1 Formula2
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>=7)*(E60<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>$D60)*(E60<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34)*(E34<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34+($G$1*$D$34))
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34>=$D$34+($G$1*$D$34))*(E34<>"")


    Could you change it to look like this:
    Type Typename Range StopIfTrue Formula1 Formula2 Formula3
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"") =(NOW()>E$7)*(E59>=8)*(E59<>"") =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"") =(NOW()>E$7)*(E60>=7)*(E60<>"") =(NOW()>E$7)*(E60>$D60)*(E60<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34)*(E34<>"") =(NOW()>E$7)*(E34<$D$34+($G$1*$D$34)) =(NOW()>E$7)*(E34>=$D$34+($G$1*$D$34))*(E34<>"")

    Thank you snb,
    Your code is always an inspiration!

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Yes I can do that, but you might also adapt the code to accomplish that.

  11. #11
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Quote Originally Posted by snb View Post
    Yes I can do that, but you might also adapt the code to accomplish that.
    I am sorry snb but I have no clue of how to adapt your code to accomplish it.

    Regards,
    vanhunk

  12. #12
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Quote Originally Posted by vanhunk View Post
    Hi snb,
    It now looks like this:
    Type Typename Range StopIfTrue Formula1 Formula2
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>=8)*(E59<>"")
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>=7)*(E60<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60>$D60)*(E60<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34)*(E34<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34+($G$1*$D$34))
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34>=$D$34+($G$1*$D$34))*(E34<>"")


    Could you change it to look like this:
    Type Typename Range StopIfTrue Formula1 Formula2 Formula3
    2 Color Scale $E$59:$P$59 TRUE =(NOW()>E$7)*(E59<=5)*(E59<>"") =(NOW()>E$7)*(E59>=8)*(E59<>"") =(NOW()>E$7)*(E59>$D59)*(E59<>"")
    2 Color Scale $E$60:$P$60 TRUE =(NOW()>E$7)*(E60<=3)*(E60<>"") =(NOW()>E$7)*(E60>=7)*(E60<>"") =(NOW()>E$7)*(E60>$D60)*(E60<>"")
    2 Color Scale $E$34 TRUE =(NOW()>E$7)*(E34<$D$34)*(E34<>"") =(NOW()>E$7)*(E34<$D$34+($G$1*$D$34)) =(NOW()>E$7)*(E34>=$D$34+($G$1*$D$34))*(E34<>"")

    Thank you snb,
    Your code is always an inspiration!
    I would really appreciate it if anyone can help me to complete this awesome code by snb. I have no idea how to do it and it would be a pity if it is left hanging.

    Regards,
    vanhunk

  13. #13
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Sub M_snb()
        On Error Resume Next
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|")
        
        With CreateObject("scripting.dictionary")
            .Item("titel") = "Type|Typename|Range|StopIfTrue|Formula1|Formula2|Formula3"
            For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions)
                For Each cf In cl.FormatConditions
                    c00 = ""
                    c00 = cf.Formula1
                    If .exists(cf.AppliesTo.Address) Then
                       If InStr(.Item(cf.AppliesTo.Address), c00) = 0 Then .Item(cf.AppliesTo.Address) = .Item(cf.AppliesTo.Address) & "|'" & c00
                    Else
                        .Item(cf.AppliesTo.Address) = cf.Type& & "|" & sp(cf.Type) & "|" & cf.AppliesTo.Address & "|" & cf.StopIfTrue & "|'" & c00
                    End If
                Next
            Next
            
            Sheets.Add.Name = "overzicht"
            Sheets("overzicht").Cells(1).Resize(.Count) = Application.Transpose(.items)
            Sheets("overzicht").Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"
        End With
    End Sub

  14. #14
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Brilliant, thank you so much snb!

    Best regards,
    vanhunk

  15. #15
    VBAX Newbie
    Joined
    Jul 2014
    Posts
    1
    Location
    I was excited to see this and the next to last script works for me but not the last one (which would be cleaner). I wish I understood how you did that without specifying an array... Any pointers to where I can learn what you actually did there??

  16. #16

  17. #17
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    the code in #13 contains an error.
    Here the revised code:

    Sub M_snb() 
        On Error Resume Next 
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|") 
         
        With CreateObject("scripting.dictionary") 
            .Item("titel") = "Type|Typename|Range|StopIfTrue|Formula1|Formula2|Formula3" 
    
            For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions) 
    
                For Each cf In cl.FormatConditions 
                    c00 = "" 
                    c00 = cf.Formula1 
    
                    If .exists(cf.AppliesTo.Address) Then 
                        If InStr(.Item(cf.AppliesTo.Address), c00) = 0 Then .Item(cf.AppliesTo.Address) = .Item(cf.AppliesTo.Address) & "|'" & c00 
                    Else 
                        .Item(cf.AppliesTo.Address) = cf.Type  & "|" & sp(cf.Type) & "|" & cf.AppliesTo.Address & "|" & cf.StopIfTrue & "|'" & c00 
                    End If 
                Next 
            Next 
             
            Sheets.Add.Name = "overzicht" 
            Sheets("overzicht").Cells(1).Resize(.Count) = Application.Transpose(.items) 
            Sheets("overzicht").Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|" 
        End With 
    End Sub

  18. #18
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Dear snb,
    If I want the list to start in cell A3, how do I adapt the excellent code supplied by you? I have tried in vain!

    Best Regards,
    vanhunk

    Sub M_snb() 
        On Error Resume Next 
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|") 
         
        With CreateObject("scripting.dictionary") 
            .Item("titel") = "Type|Typename|Range|StopIfTrue|Formula1|Formula2|Formula3" 
    
            For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions) 
    
                For Each cf In cl.FormatConditions 
                    c00 = "" 
                    c00 = cf.Formula1 
    
                    If .exists(cf.AppliesTo.Address) Then 
                        If InStr(.Item(cf.AppliesTo.Address), c00) = 0 Then .Item(cf.AppliesTo.Address) = .Item(cf.AppliesTo.Address) & "|'" & c00 
                    Else 
                        .Item(cf.AppliesTo.Address) = cf.Type  & "|" & sp(cf.Type) & "|" & cf.AppliesTo.Address & "|" & cf.StopIfTrue & "|'" & c00 
                    End If 
                Next 
            Next 
             
            Sheets.Add.Name = "overzicht" 
            Sheets("overzicht").Cells(1).Resize(.Count) = Application.Transpose(.items) 
            Sheets("overzicht").Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|" 
        End With 
    End Sub
    [/QUOTE]

  19. #19
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Probably
    Sub M_snb() 
        On Error Resume Next 
        sp = Split("Cell Value|Expression|Color Scale|DataBar|Top 10?|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||", "|") 
         
        With CreateObject("scripting.dictionary") 
            .Item("titel") = "Type|Typename|Range|StopIfTrue|Formula1|Formula2|Formula3" 
             
            For Each cl In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions) 
                 
                For Each cf In cl.FormatConditions 
                    c00 = "" 
                    c00 = cf.Formula1 
                     
                    If .exists(cf.AppliesTo.Address) Then 
                        If InStr(.Item(cf.AppliesTo.Address), c00) = 0 Then .Item(cf.AppliesTo.Address) = .Item(cf.AppliesTo.Address) & "|'" & c00 
                    Else 
                        .Item(cf.AppliesTo.Address) = cf.Type  & "|" & sp(cf.Type) & "|" & cf.AppliesTo.Address & "|" & cf.StopIfTrue & "|'" & c00 
                    End If 
                Next 
            Next 
             
            Sheets.Add.Name = "overzicht" 
            Sheets("overzicht").Cells(3,1).Resize(.Count) = Application.Transpose(.items) 
            Sheets("overzicht").cells(1).currentregion.Columns(1).offset(2).TextToColumns , , , , 0, 0, 0, 0, -1, "|" 
        End With 
    End Sub

  20. #20
    VBAX Tutor
    Joined
    Jun 2012
    Posts
    240
    Location
    Hi snb,

    What it does is separate the headings into columns, starting in A3, with the remainder below it, but all in column A. I.e. it does not split the remaining data into columns.

    Regards,
    vanhunk

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •