代码之家 › 专栏 › 技术社区 › Dan H

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

unique excel vba

-2

Dan H · 技术社区 · 6 年前

我是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

1 回复 | 直到 6 年前

tigeravatar 6 年前

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

论据:

检查范围 :必需。这是循环进行颜色计数的单元格范围
ColorCompareCell :必需。这是一个包含您想要计算的颜色的单个单元格(无法合并)。
UnqOnly公司 :可选。False(默认)表示将统计所有值,True表示仅统计唯一值。
区分大小写 :可选。仅在以下情况下相关 UnqOnly公司 设置为True。False(默认值)表示唯一值不考虑大小写。例如,“ABC”和“ABC”将是相同的唯一值,并且只计算一次。True表示将考虑该情况以确定唯一性。例如,“ABC”和“ABC”将是不同的唯一值,并且将对每个值进行计数。
忽略空白 :可选。True(默认值)表示具有空白值的单元格即使包含所选颜色也不会计数。False表示无论如何都将对具有空白值的单元格进行计数。

完整自定义项代码:

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