Need VBA code count color cells

[Don Black]

Hello All,

I am trying to create a counter for colored cells by a specific color (red), that looks at conditional formatting colors rather than the standard fill color option.



Method: 1 file - Condition_Formatting

I am trying to count only the red cells in my document in every column where they will appear. I am using conditional formatting to fill cells where people are late = red fill color.
that works fine.

My problem is I need each column to have the total count by their respective name headers in row 1.

I need to modify this code, so that I can populate the total, for all cells containing fill color red in each column. The current script display's a msgbox, but I need it to run and append the count to each column.

Sub SumCountByConditionalFormat()
    Dim indRefColor As Long
    Dim cellCurrent As Range
    Dim cntRes As Long
    Dim cntCells As Long
    Dim indCurCell As Long
   
    cntRes = 0
       
    cntCells = Selection.CountLarge
    indRefColor = ActiveCell.DisplayFormat.Interior.Color
   
    For indCurCell = 1 To (cntCells - 1)
        If indRefColor = Selection(indCurCell).DisplayFormat.Interior.Color Then
             cntRes = cntRes + 1
                 
        End If
    Next
   MsgBox "Count=" & cntRes & vbCrLf & vbCrLf & _
        "Color=" & Left("000000", 6 - Len(Hex(indRefColor))) & _
        Hex(indRefColor) & vbCrLf, , "Count by Conditional Format color"
End Sub

Method 2 file- Color Counter
I have a second method that uses (UDF) and it works, but I have to adjust the calculations on the formula bar to manual instead of automatic and then I get the proper count for each red cell. I am think that a loop would need to be created each column that I would need to do a count total. I am not a expert on loops, but if someone could look at both methods and maybe fine a better way of doing this.

Function CountColorIf(rSample As Range, rArea As Range) As Long

    Dim rAreaCell As Range
    Dim lMatchColor As Long
    Dim lCounter As Long

    lMatchColor = rSample.DisplayFormat.Interior.Color
    For Each rAreaCell In rArea
        If rAreaCell.DisplayFormat.Interior.Color = lMatchColor Then
            lCounter = lCounter + 1
        End If
    Next rAreaCell
    CountColorIf = lCounter
End Function

Sub CountColorIf2()
    Dim rSample As Range
    Dim rArea As Range
    Dim rAreaCell As Range
    Dim lMatchColor As Long
    Dim lCounter As Long
    Dim CC As Long

    Set rSample = Range("b12")
    Set rArea = Range("c5:c6")
    lMatchColor = rSample.DisplayFormat.Interior.Color
    For Each rAreaCell In rArea
        If rAreaCell.DisplayFormat.Interior.Color = lMatchColor Then
            lCounter = lCounter + 1
        End If
    Next rAreaCell
    CC = lCounter
End Sub

 

[Luke M]

Rather than trying to detect which CF is active, why not count them using the same condition that's triggering the CF? For instance, in your first file:
=COUNTA(C5:C9)-COUNTIF(C5:C9,0)

As you've learned, counting CF colors is very complicated, and not always reliable.
http://www.cpearson.com/excel/cfcolors.htm

 

[Don Black]

I figured out another method
here is the final UDF

Function CountLate(minDays As Range, maxDays As Range, ActualDates As Range, TargetDates As Range) As Long
' This function was setup to count the number of entries in the actual date column that are late vs the target column
' minDays = lower bound of days late
' maxDays = upper bound of days late ; left blank means there is no upper bound to stop at
'ActualDates = user selects the actual entry range
'TargetDates = User selects the target dates in which to compare the actual dates to.


    Dim ActAreaCell As Range
    Dim lCounter As Long
    Dim TargetCol As Long
   
    TargetCol = TargetDates.Column
     
     'if no max days provide this runs returning the entries greater than or equal to the mid days late
    If maxDays.Value = "" Then
        For Each ActAreaCell In ActualDates
        If ActAreaCell - ActAreaCell.Offset(0, (TargetDates.Column - ActAreaCell.Column)) >= minDays.Value Then
           lCounter = lCounter + 1
        End If
        Next ActAreaCell
        CountLate = lCounter
    Else
   
    ' max days provide this runs and there will be a lower bound (min days) and upper bound (max days late)
        For Each ActAreaCell In ActualDates
        If ActAreaCell - ActAreaCell.Offset(0, (TargetDates.Column - ActAreaCell.Column)) >= minDays.Value And _
        ActAreaCell - ActAreaCell.Offset(0, (TargetDates.Column - ActAreaCell.Column)) <= maxDays.Value Then
           lCounter = lCounter + 1
        End If
    Next ActAreaCell
    CountLate = lCounter
End If

End Function

and I use this formula create from the function works great.

=CountLate($B$372,$C$372,B2:B362,$A$2:$A$362) - Greater than x days late
=CountLate($B$373,$C$373,B2:B362,$A$2:$A$362) - Lookup Dates greater than X days late

 

[NARAYANK991]

Hi Don ,

See if this is what you are looking for.

Narayan

 

[Don Black]

Hi Don ,

See if this is what you are looking for.

Narayan

That works well too my friend thanks again.