Excel: Rechnen mit Farben

Gepostet am: Jan 14, 2011 9:3:58 AM

Excel stellt interessanterweise keine Funktionen für das Rechnen mit Farben zur Verfügung, obwohl dies durchaus interessant wäre. Wäre es nicht praktisch, wenn man einfach mal Excel sagen könnte, zähle mir alle grünen Felder zusammen. 

ACHTUNG: diese Berechnungen funktionieren nur mit manuell eingefärbten Zellen und nicht bei Zellen deren Farben aus einer bedingten Formatierung resultieren.

Farbe einer Zelle ermitteln

FarbID

Public Function FarbID(ByVal range As range) As Integer     FarbID = range.Interior.ColorIndex End Function

Addieren von farbigen Zellen / Summe farbiger Zellen

SummeFarbe(Bereich,FarbID,[ignoreErrors])

Public Function SummeFarbe(Bereich As range, Farbe As Integer, Optional ignoreErrors As Boolean = True) As DoubleDim i As Integer SummeFarbe = 0If Bereich Is Nothing Then     Exit FunctionEnd IfFor i = 1 To Bereich.Count     If Farbe = Bereich(i).Interior.ColorIndex Then         If ignoreErrors = True Then             If IsNumeric(Bereich(i).Value) Then                 SummeFarbe = Bereich(i).Value + SummeFarbe             End If         Else             SummeFarbe = Bereich(i).Value + SummeFarbe         End If     End IfNext i End Function

Produkt von farbigen Zellen

ProduktFarbe(Bereich,FarbID,[ignoreErrors])

Public Function ProduktFarbe(Bereich As range, Farbe As Integer, Optional ignoreErrors As Boolean = True) As DoubleDim i As Integer ProduktFarbe = 1If Bereich Is Nothing Then     ProduktFarbe = 0     Exit FunctionEnd IfFor i = 1 To Bereich.Count     If Farbe = Bereich(i).Interior.ColorIndex Then         If ignoreErrors = True Then             If IsNumeric(Bereich(i).Value) Then                 ProduktFarbe = Bereich(i).Value * ProduktFarbe             End If         Else             ProduktFarbe = Bereich(i).Value * ProduktFarbe         End If     End IfNext i End Function

Maximalwert der farbigen Zellen

MaxFarbe(Bereich,FarbID,[Stelle,ignoreErrors])

Public Function MaxFarbe(Bereich As range, Farbe As Integer, Optional Stelle As Integer = 1, Optional ignoreErrors As Boolean = True) As VariantDim i As IntegerDim j As IntegerDim myArray() As DoubleDim myArray2() As DoubleDim vTemp As Double  j = 0'Bereich auslesen und in unsortierten Array schreibenFor i = 1 To Bereich.Count     If Farbe = Bereich(i).Interior.ColorIndex Then         If ignoreErrors = True Then             If IsNumeric(Bereich(i).Value) Then                 ReDim Preserve myArray(j)                 myArray(j) = Bereich(i).Value                 j = j + 1             End If         Else             ReDim Preserve myArray(j)             myArray(j) = Bereich(i).Value             j = j + 1         End If     End IfNext'Array sortieren - Quelle: http://msdn.microsoft.com/de-de/library/bb979305.aspx   For j = UBound(myArray) - 1 To LBound(myArray) Step -1     ' Alle links davon liegenden Zeichen auf richtige Sortierung     ' der jeweiligen Nachfolger überprüfen:     For i = LBound(myArray) To j       ' Ist das aktuelle Element seinem Nachfolger gegenüber korrekt sortiert?       If myArray(i) > myArray(i + 1) Then         ' Element und seinen Nachfolger vertauschen.         vTemp = myArray(i)         myArray(i) = myArray(i + 1)         myArray(i + 1) = vTemp       End If     Next i   Next j    'doppelte Werte des Arrays entfernen j = 0     For i = 0 To UBound(myArray) Step 1         If i = 0 Then             ReDim Preserve myArray2(j)             myArray2(j) = myArray(i)             j = j + 1         Else             If myArray(i) <> myArray2(j - 1) Then                 ReDim Preserve myArray2(j)                 myArray2(j) = myArray(i)                 j = j + 1             End If         End If     Next i  If Stelle > UBound(myArray2) + 1 Then     MaxFarbe = "#Fehler"Else     MaxFarbe = myArray2(UBound(myArray2) - Stelle + 1)End IfEnd Function

Minimalwert der farbigen Zellen

Textfeld(Bereich,FarbID,[Stelle,ignoreErrors])

Public Function MinFarbe(Bereich As range, Farbe As Integer, Optional Stelle As Integer = 1, Optional ignoreErrors As Boolean = True) As VariantDim i As IntegerDim j As IntegerDim myArray() As DoubleDim myArray2() As DoubleDim vTemp As Double  j = 0'Bereich auslesen und in unsortierten Array schreibenFor i = 1 To Bereich.Count     If Farbe = Bereich(i).Interior.ColorIndex Then         If ignoreErrors = True Then             If IsNumeric(Bereich(i).Value) Then                 ReDim Preserve myArray(j)                 myArray(j) = Bereich(i).Value                 j = j + 1             End If         Else             ReDim Preserve myArray(j)             myArray(j) = Bereich(i).Value             j = j + 1         End If     End IfNext'Array sortieren - Quelle: http://msdn.microsoft.com/de-de/library/bb979305.aspx   For j = UBound(myArray) - 1 To LBound(myArray) Step -1     ' Alle links davon liegenden Zeichen auf richtige Sortierung     ' der jeweiligen Nachfolger überprüfen:     For i = LBound(myArray) To j       ' Ist das aktuelle Element seinem Nachfolger gegenüber korrekt sortiert?       If myArray(i) > myArray(i + 1) Then         ' Element und seinen Nachfolger vertauschen.         vTemp = myArray(i)         myArray(i) = myArray(i + 1)         myArray(i + 1) = vTemp       End If     Next i   Next j    'doppelte Werte des Arrays entfernen j = 0     For i = 0 To UBound(myArray) Step 1         If i = 0 Then             ReDim Preserve myArray2(j)             myArray2(j) = myArray(i)             j = j + 1         Else             If myArray(i) <> myArray2(j - 1) Then                 ReDim Preserve myArray2(j)                 myArray2(j) = myArray(i)                 j = j + 1             End If         End If     Next i  If Stelle > UBound(myArray2) + 1 Then     MinFarbe = "#Fehler"Else     MinFarbe = myArray2(Stelle - 1)End IfEnd Function

Sie hätten gerne eine neue "Farb-Funktion", dann kontaktieren Sie mich. Wenn ich sie für praktisch relevant erachte, dann erstelle ich sie für Sie gerne.