在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时才有效。假（默认）意味着唯一值不考虑大小写。例如，“ABC”和“abc”将是相同的唯一值并且只计算一次。 “真”意味着将案件考虑在内以确定唯一性。例如，“ABC”和“abc”将是不同的唯一值，每个值都会被计数。
• IgnoreBlanks：可选。真（默认）意味着具有空白值的单元格即使包含所选颜色也不会被计数。 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