在 Excel VBA 中按颜色计算唯一单元格值

Question

我是 VBA 新手。

Endstate - 搜索范围并计算用户指定填充颜色的唯一单元格值的实例，将合并的单元格（我知道，合并会破坏一切）作为一个完整的单元格。

我已经编译了下面的代码，但它不能正常工作，任何帮助将不胜感激！

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

因为我认为它很有趣，所以我创建了一个 UDF，它可以确保它只计算一次合并的单元格，默认情况下会忽略空白（不必），并且会计算所有具有所选颜色的单元格，但只能计算这些单元格的唯一值作为选项。要使用它以便它只计算您想要的所选颜色的唯一值，公式为：=CountColor(A1:C4,A3,TRUE)

参数：

• 检查范围：必需。这是将循环通过以进行颜色计数的单元格范围
• ColorCompareCell：必需。这是一个包含您想要计算的颜色的单元格（无法合并）。
• UnqOnly：可选。 False（默认）表示将计算所有值，True 表示仅计算唯一值。
• 区分大小写：可选。仅当 UnqOnly 设置为 True 时才相关。 False（默认）表示唯一值不考虑大小写。例如，“ABC”和“abc”将是相同的唯一值并且只计算一次。 True 表示考虑大小写以确定唯一性。例如，“ABC”和“abc”将是不同的唯一值，每个都将被计算在内。
• IgnoreBlanks：可选。 True（默认值）意味着即使包含所选颜色，也不会计算具有空白值的单元格。 False 表示无论如何都会计算具有空白值的单元格。

完整的 UDF 代码：

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