vba loop conditional formatted cell

[arguros]

Hi,

I have sereval conditional formatted cells in different spreadsheets.
The list of cells that have the conditional formatting applied can be seen as cells that have failed a validation rule, represented by the conditional formatting formula.
ex: Cell < 0
ex: IsErr(Cell)
ex: 0 < Cell < 0.2

All i need is to have a report that summarize them all.

I need to loop through the conditionally formatted cells, pick up the ones for which the condition is true, and write down a sort of report in anothe excel file.

A sort of
For each cell that has a condition formatting and this condition is met then
write worksheet Name, cell.Address and Cell Value, and formula error

end

Is there any way of doing it?

Thanks

 

[Jaye7]

The following works, change the Error1, Error2, Error3 values to your own values.

Option Compare Text
Sub Summarize()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim bTest As Boolean
Dim rCopy As Range
Dim rPaste As Range
Dim lngLastRow As Long
Dim lngLastRowCons As Long
Dim strConsTab As String, ws2 As String, msg As String

For Each ws In Worksheets
    If ws.Name = "Summary" Then
        bTest = True
        Exit For
    End If
Next ws
If bTest = True Then
Application.DisplayAlerts = False
Worksheets("Summary").Delete
Application.DisplayAlerts = True
GoTo part2
    
Else
MsgBox "sheet does not exits"
part2:
Dim sheetname As String
sheetname = ActiveSheet.Name
Sheets.Add
ActiveSheet.Name = "Summary"
    
    strConsTab = "Summary" 'Consolidation sheet tab name
    
    'Clear any existing data from the consolidation tab or else each _
    sheet in the work will keep appending to it each time the macro is run.
    lngLastRowCons = Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
    If lngLastRowCons > 1 Then
        Sheets(strConsTab).Range("A2:U" & lngLastRowCons).ClearContents
    End If
     
    For Each wSheet In Worksheets
        If wSheet.Name <> strConsTab Then
     wSheet.Select
               
 With wSheet
Dim myLastRow As Long
Dim myLastColumn As Long
Range("A1").Select
 On Error Resume Next
    myLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
    myLastColumn = Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
    myLastCell = Cells(myLastRow, myLastColumn).Address
myRange = "a1:" & myLastCell
Range(myRange).Select
                
     End With
     
  For Each cell In Selection
  
  ' change the error values to your own values
  
  If cell.Value = "[COLOR=#ff0000]Error1[/COLOR]" Or cell.Value = "[COLOR=#ff0000]Error2[/COLOR]" Or cell.Value = "[COLOR=#ff0000]Error3[/COLOR]" Then
  
  msg = "Worksheet Name: " & wSheet.Name & "     Cell Address: " & cell.Address & "     Cell Value: " & cell.Value
            
        lngLastRowCons = Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
            lngLastRowCons = lngLastRowCons + 1
         Sheets(strConsTab).Range("A" & lngLastRowCons).Value = msg
            
      End If
    Next
    
    End If
    Next wSheet
    
    Sheets(strConsTab).Select
    
End If
Application.ScreenUpdating = True
End Sub