Zählen Sie einzigartige Zellenwerte nach Farbe in Excel VBA

Question

Ich bin neu in VBA.

Endstate - Durchsuche einen Bereich und zähle Instanzen von eindeutigen Zellenwerten für eine vom Benutzer angegebene gefüllte Farbe, die zusammengeführte Zellen zählt (ich weiß, alles ruinieren) als eine ganze Zelle.

Ich habe den untenstehenden Code zusammengestellt, aber es funktioniert nicht ganz richtig, jede Hilfe wäre sehr willkommen!

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

Und weil ich dachte, es hat Spaß gemacht, hier ist ein UDF erstellt ich sicher, dass es wird nur eine verbundene Zelle einmal zählt, werden Rohlinge standardmäßig ignorieren (muss nicht), und alle Zellen zählen mit die ausgewählte Farbe, kann jedoch nur eindeutige Werte für diese Zellen als Option zählen. Um es zu nutzen, so dass es nur eindeutige Werte für die gewählte Farbe zählt, wie Sie beabsichtigen, würde die Formel: =CountColor(A1:C4,A3,TRUE)

Argumente:

• Checkrange: Erforderlich. Dies ist der Bereich der Zellen, die für die Farbzählung durchgeschleift werden.
• ColorCompareCell: Erforderlich. Dies ist eine einzelne Zelle (nicht zusammenführbar), die die Farbe enthält, die Sie zählen möchten.
• UnqOnly: Optional. False (Standard) bedeutet, dass alle Werte gezählt werden, True bedeutet, dass nur eindeutige Werte gezählt werden.
• CaseSensitive: Optional. Nur relevant, wenn UnqOnly auf True gesetzt ist. Falsch (Standard) bedeutet, dass eindeutige Werte nicht berücksichtigt werden. Zum Beispiel wären "ABC" und "abc" derselbe eindeutige Wert und würden nur einmal gezählt. Wahr bedeutet, dass der Fall berücksichtigt wird, um die Eindeutigkeit zu bestimmen. Zum Beispiel wären "ABC" und "abc" unterschiedliche eindeutige Werte und jeder würde gezählt werden.
• IgnoreBlanks: Optional. True (Standard) bedeutet, dass Zellen mit leeren Werten nicht gezählt werden, auch wenn sie die gewählte Farbe enthalten. False bedeutet, dass Zellen mit leeren Werten trotzdem gezählt werden.

Voll UDF Code:

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