在Excel中按顏色計算唯一單元格值VBA

-2

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

來源

2017-12-27 Dan H

什麼是你期望得到什麼，你實際上得到？ – QHarr

當我在Excel中運行代碼時，我得到的答案是實際計數的+1，我不確定原因。另外，我想知道除了使用腳本字典以外，是否還有一種更有效的方式來執行唯一值搜索，但沒有將函數限制爲只有數值。 –

+1是由於合併的單元格被視爲空白，所以空白是一個新的獨特值，並給您一個額外的。添加一個if語句來檢查Len（cell.value）> 0'以確保您忽略空格。 – tigeravatar

而且我覺得很有趣，這是我創建了一個將確保其只計算合併單元格一次，將忽略默認空格的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

來源

2017-12-27 16:05:17 tigeravatar

解決了它並提供了額外的功能！但是，不是下面的還原嗎？無論哪種方式TotalCount = TotalCount +1？如果Len（Trim（CheckCell.Value））> 0則TotalCount = TotalCount + 1 否則 TotalCount = TotalCount + 1 –

在Excel中按顏色計算唯一單元格值VBA

回答

相關問題