Count Unique Cell Values by Color in Excel VBA

Question

I'm new to VBA.

Endstate - search through a range and count instances of unique cell values for a user specified filled color counting merged cells (I know, merging ruins everything) as one whole cell.

I've compiled the below code but it's not working quite right, any help would be greatly appreciated!

Function CountUniqueColorBlocks(SearchRange As Range, ColorRange As Range) As Long
Dim cell As Range, blocks As Range
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
Set blocks = SearchRange(1).MergeArea(1) ' prime union method (which requires >1 value)
For Each cell In SearchRange
    If cell.Interior.Color = ColorRange.Interior.Color And Not dict.Exists(cell.Value) Then
        dict.Add cell.Value, 0
 End If
Next
CountUniqueColorBlocks = dict.Count
End Function

Answer 1

And because I thought it was fun, here's a UDF I created that will ensure it only counts a merged cell once, will ignore blanks by default (doesn't have to), and will count all cells with the chosen color, but can only count unique values for those cells as an option. To use it so that it only counts unique values for the chosen color as you intend, the formula would be: =CountColor(A1:C4,A3,TRUE)

Arguments:

• CheckRange: Required. This is the range of cells that will be looped through for color counting
• ColorCompareCell: Required. This is a single cell (cannot be merged) that contains the color you would like counted.
• UnqOnly: Optional. False (default) means all values will be counted, True means only unique values will be counted.
• CaseSensitive: Optional. Only relevant when UnqOnly is set to True. False (default) means that unique values do not take case into consideration. For example, "ABC" and "abc" would be the same unique value and only counted once. True means that case is taken into account to determine uniqueness. For example, "ABC" and "abc" would be different unique values and each would be counted.
• IgnoreBlanks: Optional. True (default) means that cells with blank values will not be counted even if they contain the chosen color. False means that cells with blank values will be counted anyway.

Full UDF code:

Public Function CountColor(ByVal CheckRange As Range, _
                           ByVal ColorCompareCell As Range, _
                           Optional ByVal UnqOnly As Boolean = False, _
                           Optional ByVal CaseSensitive As Boolean = False, _
                           Optional ByVal IgnoreBlanks As Boolean = True) As Variant

    Dim UnqValues As Object
    Dim NewCell As Boolean
    Dim CheckCell As Range
    Dim MergedCells As Range
    Dim TotalCount As Long

    If ColorCompareCell.Cells.Count <> 1 Then
        CountColor = CVErr(xlErrRef)
        Exit Function
    End If

    If UnqOnly Then Set UnqValues = CreateObject("Scripting.Dictionary")

    For Each CheckCell In CheckRange.Cells
        NewCell = False
        If CheckCell.MergeArea.Address <> CheckCell.Address Then
            If MergedCells Is Nothing Then
                Set MergedCells = CheckCell.MergeArea
                NewCell = True
            Else
                If Intersect(CheckCell, MergedCells) Is Nothing Then
                    Set MergedCells = Union(MergedCells, CheckCell.MergeArea)
                    NewCell = True
                End If
            End If
        Else
            NewCell = True
        End If

        If NewCell Then
            If CheckCell.Interior.Color = ColorCompareCell.Interior.Color Then
                If UnqOnly Then
                    If CaseSensitive Then
                        If IgnoreBlanks Then
                            If Len(Trim(CheckCell.Value)) > 0 Then UnqValues(WorksheetFunction.Trim(CheckCell.Value)) = WorksheetFunction.Trim(CheckCell.Value)
                        Else
                            UnqValues(WorksheetFunction.Trim(CheckCell.Value)) = WorksheetFunction.Trim(CheckCell.Value)
                        End If
                    Else
                        If IgnoreBlanks Then
                            If Len(Trim(CheckCell.Value)) > 0 Then UnqValues(LCase(WorksheetFunction.Trim(CheckCell.Value))) = LCase(WorksheetFunction.Trim(CheckCell.Value))
                        Else
                            UnqValues(LCase(WorksheetFunction.Trim(CheckCell.Value))) = LCase(WorksheetFunction.Trim(CheckCell.Value))
                        End If
                    End If
                Else
                    If IgnoreBlanks Then
                        If Len(Trim(CheckCell.Value)) > 0 Then TotalCount = TotalCount + 1
                    Else
                        TotalCount = TotalCount + 1
                    End If
                End If
            End If
        End If
    Next CheckCell

    If UnqOnly Then CountColor = UnqValues.Count Else CountColor = TotalCount

End Function