ZählenWennFormat

Das Problem

Excel bietet keine Funktion um Zellen zu zählen welche gleich formatiert sind.

Die Lösung

Über eine selbst definierte Funktion kann Excel einen Zellbereich auf gleich formatierte Zellen prüfen.
Dabei bietet sich das Konstrukt einer Vergleichszelle an. Andernfalls würde die Vergleichsoperation sehr unhandlich werden.

mit Einschränkungen...

Das Problem an diesem Vergleich ist, dass Excel selbst das Arbeitsblatt nicht neu berechnet wenn die Formatierung geändert wird. Dies bedeutet, dass das Ergebnis der Funktion nach reiner Formatänderung falsch sein kann.
Abhilfe schafft ein Trick in der Ergebniszelle indem man zum Ergebnis 0 mal das heutige Datum addiert (=ZählenWennFormat(A2:C6;D3)+0*HEUTE()) und nach Änderung die Neuberechnung mit F9 erzwingt.

Quellcode ›ZaehlenWennFormat.bas‹

Attribute VB_Name = "myFunctions"
Option Explicit

Public Function ZählenWennFormat(Bereich As Range, Referenzzelle As Range, Optional nurHintergrund As Boolean) As Long

    'Bsp.: =ZählenWennFormat(A2:C6;D3)
    'BSp.: =ZählenWennFormat(A2:C6;D3,1) wenn nur der Hintergrund berücksichtigt werden soll
    'PROBLEM: EXCEL berechnet nicht neu, wenn das Format geändert wurde
    '-> Abhilfe '=ZählenWennFormat(A2:C6;D3)+0*HEUTE()' und anschließend mit 'F9' das Arbeitsblatt neu berechnen
    'zählt die Anzahl der Zellen innerhalb von A2:C6 welche das Format von D3 besitzen
    'Format berücksichtigt den Hintergrund der Zelle (Farbe, Muster und Musterfarbe)
    'und den Vordergrund (Schiftfarbe, Fettschrift, Kursivschrift, Unterstreichung, Schriftname und Schriftgröße)
    'soll nur der Hintergrund berücksichtigt werden, muss als dritter Parameter WAHR / TRUE / 1 übergeben werden
    
    Dim i, j As Long
    Dim myCellColorIndex, myCellColor, myPatternColorIndex, myPattern, myPatternColor As Variant
    Dim myFontColor, myFontBold, myFontUnderline, myFontName, myFontSize As Variant
    Dim myFontItalic As Boolean
    
    myCellColorIndex = Referenzzelle.Interior.ColorIndex
    myCellColor = Referenzzelle.Interior.Color
    myPattern = Referenzzelle.Interior.Pattern
    myPatternColorIndex = Referenzzelle.Interior.PatternColorIndex
    myPatternColor = Referenzzelle.Interior.PatternColor
    myFontColor = Referenzzelle.Font.ColorIndex
    myFontBold = Referenzzelle.Font.Bold
    myFontItalic = Referenzzelle.Font.Italic
    myFontUnderline = Referenzzelle.Font.Underline
    myFontName = Referenzzelle.Font.Name
    myFontSize = Referenzzelle.Font.Size
    
    ZählenWennFormat = 0
    
    For i = 1 To Bereich.Rows.Count
        For j = 1 To Bereich.Columns.Count
            'Hintergrundfarbe
            If (Bereich(i, j).Interior.ColorIndex = myCellColorIndex) And (Bereich(i, j).Interior.Color = myCellColor) Then
                'Hintergrundmuster
                If (Bereich(i, j).Interior.Pattern = myPattern) And (Bereich(i, j).Interior.PatternColor = myPatternColor) And (Bereich(i, j).Interior.PatternColorIndex = myPatternColorIndex) Then
                    If Not nurHintergrund Then
                        'Schriftbild
                        If (Bereich(i, j).Font.ColorIndex = myFontColor) And (Bereich(i, j).Font.Bold = myFontBold) And (Bereich(i, j).Font.Italic = myFontItalic) And (Bereich(i, j).Font.Underline = myFontUnderline) And (Bereich(i, j).Font.Name = myFontName) And (Bereich(i, j).Font.Size = myFontSize) Then
                            ZählenWennFormat = ZählenWennFormat + 1
                        End If
                    Else
                       ZählenWennFormat = ZählenWennFormat + 1
                    End If
                End If
            End If
        Next
    Next

End Function