PDA

View Full Version : [SOLVED] Listing Conditional Formatting on Separate Sheet or Workbook



vanhunk
05-15-2014, 04:20 AM
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/2010/04/16/listing-format-conditions/#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

Bob Phillips
05-15-2014, 06:09 AM
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

snb
05-15-2014, 09:28 AM
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

vanhunk
07-01-2014, 02:38 AM
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

vanhunk
07-01-2014, 02:42 AM
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

snb
07-01-2014, 04:35 AM
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

vanhunk
07-01-2014, 04:58 AM
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

snb
07-01-2014, 05:54 AM
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

vanhunk
07-01-2014, 06:21 AM
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!

snb
07-01-2014, 06:38 AM
Yes I can do that, but you might also adapt the code to accomplish that.

vanhunk
07-01-2014, 07:01 AM
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

vanhunk
07-02-2014, 06:23 AM
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

snb
07-02-2014, 06:53 AM
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

vanhunk
07-02-2014, 07:26 AM
Brilliant, thank you so much snb!

Best regards,
vanhunk

shellig
07-14-2014, 07:01 PM
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??

snb
07-15-2014, 12:39 AM
Have a look at:

http://www.snb-vba.eu/VBA_Dictionary_en.html

snb
07-15-2014, 01:37 AM
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

vanhunk
09-22-2015, 04:20 AM
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]

snb
09-22-2015, 04:29 AM
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

vanhunk
09-22-2015, 04:51 AM
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

vanhunk
09-22-2015, 05:27 AM
Hi snb,
I have replaced the following line:

Sheets("overzicht").cells(1).currentregion.Columns(1).offset(2).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

with

Sheets("overzicht").Cells(3, 1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

and got the desired results.

The code now look as follows:

Sub M_snbModified()
Dim sp As Variant
Dim cl As Range
Dim cf As Variant
Dim c00 As String

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 Worksheets("GTL Dashboard").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(3, 1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

End With
End Sub

Regards,
vanhunk

snb
09-22-2015, 05:47 AM
No objection your honour.:yes

r.d-moore
05-01-2017, 10:24 AM
PLEASE HELP!!

I am crossing my fingers that someone is still around to help me with this.
I am trying desperately to implement this code into my workbook in an attempt to get a list of all Conditional Formatting rules.
I am only able to get the column headers to show when running the code. I am unable to get anything to populate under the headers.



Hi snb,
I have replaced the following line:

Sheets("overzicht").cells(1).currentregion.Columns(1).offset(2).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

with

Sheets("overzicht").Cells(3, 1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

and got the desired results.

The code now look as follows:

Sub M_snbModified()
Dim sp As Variant
Dim cl As Range
Dim cf As Variant
Dim c00 As String

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 Worksheets("GTL Dashboard").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(3, 1).CurrentRegion.Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"

End With
End Sub

Regards,
vanhunk

vanhunk
05-17-2017, 04:26 AM
Hi r.d-moore,
I trust by now you have solved your problem, if not, please load a copy of your spreadsheet and I will have a look at it.

Regards
vanhunk