2017-12-27 129 views
-2

我是VBA的新手。在Excel中按颜色计算唯一单元格值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 
+5

什么是你期望得到什么,你实际上得到? – QHarr

+0

当我在Excel中运行代码时,我得到的答案是实际计数的+1,我不确定原因。另外,我想知道除了使用脚本字典以外,是否还有一种更有效的方式来执行唯一值搜索,但没有将函数限制为只有数值。 –

+0

+1是由于合并的单元格被视为空白,所以空白是一个新的独特值,并给您一个额外的。添加一个if语句来检查Len(cell.value)> 0'以确保您忽略空格。 – tigeravatar

回答

0

而且我觉得很有趣,这是我创建了一个将确保其只计算合并单元格一次,将忽略默认空格的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 
+0

解决了它并提供了额外的功能!但是,不是下面的还原吗?无论哪种方式TotalCount = TotalCount +1? 如果Len(Trim(CheckCell.Value))> 0则TotalCount = TotalCount + 1 否则 TotalCount = TotalCount + 1 –

相关问题