在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)

参数：

• CheckRange：必需。这是将循环进行颜色计数的单元格范围
• ColorCompareCell：必需。这是包含您要计算的颜色的单个单元格（无法合并）。
• UnqOnly：可选。 False（默认值）表示将计算所有值，True表示仅计算唯一值。
• CaseSensitive：可选。仅在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