VBA code to create list of conditional formatted ranges

[Romulus]

Hi all,

I have got this huge Excel file (*.xls, used on Windows XP, with Excel 2007), the file contains 3 sheets, one of them contains more than 246,000 formulas.

Even if there are so many formulas, there are "only" 40 different conditional formatting styles.

I need a VBA code that will search entire file, it will search each and every sheet and it will generate a report, a simple table, with following columns:

1). # - current number, e.g. 1, 2, ... n, where n is number of different conditional formats (in this case n = 40);

2). Range formatted - for instance A1:B22;

3). No. of CF conditions - number of conditional formatting conditions, e.g. from 1 to 3 (even if Excel 2007 could handle more than 3 conditions, I would limit the value to 3, because the file will be also used on other older Excel versions, which cannot handle more than 3 conditions);

4). Rule type - there are 2 possible values: Formatting or Formula;

5). Operator - one of these options: between, not between, equal to, not equal to, greater than, less than, greater than or equal to, less than or equal to;

6). Formula 1 - complete formula for first condition, if the rule type is "formula"; if rule type is "Formatting", then the value for formula 1 should be "N/A";

7). Formula 2 - complete formula for second condition, if the rule type is "formula"; if rule type is "Formatting", then the value for formula 2 should be "N/A";

8). Formula 3 - complete formula for third condition, if the rule type is "formula"; if rule type is "Formatting", then the value for formula 3 should be "N/A";

9). Font & fill colour 1 - colour of the font and colour of the fill, if condition 1 is TRUE;

10). Font & fill colour 2 - colour of the font and colour of the fill, if condition 2 is TRUE;

11). Font & fill colour 3 - colour of the font and colour of the fill, if condition 3 is TRUE.

If there are sheets with no cells formatted, the report shuold generate sheet name and "This sheet contains no cells with conditional formatting".

I have searched a solution to this problem, I could not find it. Actually, there is a solution, Power Utility Pak version 7.1 (for Excel 2007 and Excel 2010), but that solution generates a list of almost 1,000,000 rows, with details for each cell. What I need is a consolidated version, the list should refer to each type of conditional formatting, not to each cell.

If there is a topic containing a solution to this problem, let me know. Please assist.

Thank you and have a great day .

[Bob Phillips]

I cannot imagine anyone here is going to create data to test all of that lot. I might be willing to have a go, IF you pos a workbook to test it on.

[Romulus]

Hello xld,

Thank you for your interest in this challange. I can easily post the file, but I need your permission, simply because the file is almost 10 MB big.

Would it be OK with you if I posted such a file ? Thank you.

Romulus.

[Bob Phillips]

Unless it compresses enormously, the board won't accept it (there is file size limit, not sure how much). There must be tons of duplication re the CF. Could you not cut it down?

[Romulus]

I have archived the file, ZIP file has got only 1.94 MB. The maximum size allowed is 1 MB.

To solve the problem I have created a reduced version of the file, with only 100 rows of data to be processed (original file has got 3,000 rows of data). File size went down from 9.95 MB to 624 KB . I have attached it.

However, the structure of the file must stay untouched, I cannot modify anything.

The VBA code I am looking for should inspect all 3 worksheets and report in the structured way entire information requested, with regards to conditional formatting.

Thank you once again.

[Bob Phillips]

The VBA is password protected.

[Romulus]

I am sorry, I forgot . I have attached the file with no password.

[Bob Phillips]

How about this? Be warned, it ain't quick

[vba]

Public Sub LisCFs()
Const SHEET_OUTPUT As String = "_Results"
Dim ws As Worksheet
Dim cell As Range
Dim wsOut As Worksheet
Dim rowOut As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveWorkbook

Application.DisplayAlerts = False
On Error Resume Next
Set wsOut = .Worksheets(SHEET_OUTPUT)
wsOut.Cells.ClearContents
If wsOut Is Nothing Then Set wsOut = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
wsOut.Name = SHEET_OUTPUT
On Error GoTo 0
Application.DisplayAlerts = True

With wsOut

With .Range("A1:I1")

.Value = Array("WS", "Cell", "Count", "Type", "Formula 1", "Formula 2", "Formula 3", "Fill", "Font")
.Font.ColorIndex = 5
.Font.Bold = True
.Interior.ColorIndex = 6
End With

rowOut = 2
For Each ws In .Parent.Worksheets

If ws.Name <> SHEET_OUTPUT Then

.Cells(rowOut, "A").Value = ws.Name

For Each cell In ws.UsedRange

If cell.FormatConditions.Count > 0 Then

.Cells(rowOut, "B").Value = cell.Address(False, False)
.Cells(rowOut, "C").Value2 = cell.FormatConditions.Count
For i = 1 To cell.FormatConditions.Count

.Cells(rowOut, "D").Value2 = FormatType(cell.FormatConditions(i).Type)
If cell.FormatConditions(i).Type = 1 Then

.Cells(rowOut, "E").Value2 = FormatCellValue(cell.FormatConditions(i))
Else

.Cells(rowOut, "E").Value2 = "'" & CStr(cell.FormatConditions(i).Formula1)
On Error Resume Next
.Cells(rowOut, "F").Value2 = "'" & CStr(cell.FormatConditions(i).formula2)
On Error GoTo 0
End If

.Cells(rowOut, "H").Value2 = FormatFillCI(cell.FormatConditions(i).Interior.ColorIndex)
.Cells(rowOut, "I").Value2 = FormatFontCI(cell.FormatConditions(i).Font.ColorIndex)

rowOut = rowOut + 1
Next i
End If
Next cell
End If
Next ws

.Columns("A:M").AutoFit
End With
End With

Application.ScreenUpdating = True
End Sub

Private Function FormatType(ByVal CFType As Long)

Select Case CFType

Case 1: FormatType = "Cell Value"

Case 2: FormatType = "Formula"

Case Else: FormatType = "???"
End Select
End Function

Public Function FormatCellValue( _
ByVal FC As FormatCondition) As String

Select Case FC.Operator

Case xlBetween:

FormatCellValue = "Between " & FC.Formula1 & " and " & FC.formula2

Case xlEqual:

FormatCellValue = "Equal to " & FC.Formula1

Case xlGreaterEqual:

FormatCellValue = "Greater than or equal to " & FC.Formula1

Case xlLess:

FormatCellValue = "Less than " & FC.Formula1

Case xlLessEqual:

FormatCellValue = "Less than or equal to " & FC.Formula1

Case xlNotBetween:

FormatCellValue = "Not between " & FC.Formula1 & " and " & FC.formula2

Case xlNotEqual:

FormatCellValue = "Not equal to " & FC.Formula1
End Select
End Function

Private Function FormatFillCI(ByVal CI As Variant) As Variant

Select Case CI

Case Null: FormatFillCI = ""

Case xlColorIndexNone: FormatFillCI = "None"

Case Else: FormatFillCI = CI
End Select
End Function

Private Function FormatFontCI(ByVal CI As Variant) As Variant

Select Case CI

Case Null: FormatFontCI = ""

Case xlColorIndexAutomatic: FormatFontCI = "Automatic"

Case Else: FormatFontCI = CI
End Select
End Function[/vba]

[mikerickson]

This might shorten the loops.
[VBA]
On Error Goto LoopNextSheet
For Each cell In ws.Cells.SpecialCells(xlCellTypeAllFormatConditions)
On Error Goto 0


Next cell
LoopNextSheet:
On Error Goto 0[/VBA]

[Bob Phillips]

Gee, thanks Mike, for pointing out how I missed the obvious

Seriously, I don't know why, but after all these years I still have a blind spot with SpecialCells. I just don't think of them naturally. CellTypeVisible probably yes, but not the rest, FormatConditions, Blanks, Constants, I seem to pass them by usually.