Post by isibuhIch möchte gerne innerhalb einer Zeile, am ende dieser, alle farblich
markierten Zellen addieren. Wie müßte die Formel lauten wenn Excel
beispielsweise innerhalb der Zeile alle grün formatierten Felder erkennen und
dann +1 zählen soll -alle unformatierten also weißen Felder =+0 ?
Dies ist ein recht schwieriges Unterfangen welches sich nur mit einer
benutzerdefinierten Funktion lösen lässt.
Außerdem wird die Formel nur selten oder gar nicht darauf reagieren
wenn die Formatierung einer Zelle sich ändert. Wird die Zelle evt.
durch eine bedingte Formatierung eingefärbt, dann sind bei bestimmten
Bedingungen je nach Excelversion falsche Ergebnisse möglich.
Der angehängte Code gehört in ein normales Modul, wie's geht steht
hier:
http://www.online-excel.de/excel/singsel_vba.php?f=44#s2
Andreas.
Option Explicit
#Const BedingteFormatierung = True
#If BedingteFormatierung Then
'Der Code benutzt die ActiveCondition-Routine von _
http://www.cpearson.com/excel/CFColors.htm
'Hinweis: ActiveCondition kann in einem ungenauen _
Ergebnis führen, wenn die folgenden Bedingungen _
erfüllt sind:
'Sie rufen ActiveCondtion aus einer Tabellenzelle und
'Die Zelle arbeitet mit einer "Formel ist" und nicht _
"Zellwert ist" Bedingung und
'Die Formel in der Bedingung enthält relative Adressen
#End If
Function ZELLEN(Bereich As Range) As Long
'Liefert die Anzahl aller Zellen in Bereich
Dim A As Range
For Each A In Bereich.Areas
ZELLEN = ZELLEN + A.Count
Next
End Function
Function FarbigeZellen(Bereich As Range, Zelle As Range, _
Optional Vordergrund, _
Optional Hintergrund, _
_
Optional Farbe, _
Optional Schriftart, _
Optional Schriftschnitt, _
Optional Schriftgrad, _
Optional Unterstreichung, _
Optional Durchgestrichen, _
Optional Tiefgestellt, _
Optional Hochgestellt, _
_
Optional Muster, _
Optional Musterfarbe _
) As Range
'Liefert eine Matrix mit allen Zellen in Bereich die _
die gleichen Attribute wie Zelle haben.
'Welche Attribute berücksichtigt werden sollen muss _
mit 1 (=WAHR) angegeben werden.
'Beispiele:
' =ZELLEN(FarbigeZellen(A1:A10;B1;;1;1)) _
zählt alle Zellen in A1:A10 die die gleiche _
Hintergrundfarbe wie B1 haben.
' =SUMME(FarbigeZellen(A1:B10;C1;;1;1)) _
summiert alle Zellen in A1:A10 die die gleiche _
Hintergrundfarbe wie B1 haben.
Dim R As Range, Ok As Boolean, AC As Integer, O As Object
'Prüfe auf gesetzte Parameter
If IsMissing(Vordergrund) Then Vordergrund = False
If IsMissing(Hintergrund) Then Hintergrund = False
If IsMissing(Farbe) Then Farbe = False
If IsMissing(Schriftart) Then Schriftart = False
If IsMissing(Schriftschnitt) Then Schriftschnitt = False
If IsMissing(Schriftgrad) Then Schriftgrad = False
If IsMissing(Unterstreichung) Then Unterstreichung = False
If IsMissing(Durchgestrichen) Then Durchgestrichen = False
If IsMissing(Tiefgestellt) Then Tiefgestellt = False
If IsMissing(Hochgestellt) Then Hochgestellt = False
If IsMissing(Muster) Then Muster = False
If IsMissing(Musterfarbe) Then Musterfarbe = False
'Durchlaufe alle Zellen
For Each R In Bereich
Ok = True
#If BedingteFormatierung Then
AC = ActiveCondition(R)
#Else
AC = 0
#End If
'Vordergrund prüfen?
If Vordergrund Then
If AC = 0 Then
Set O = R.Interior
Else
Set O = R.FormatConditions(AC).Interior
End If
With Zelle.Cells(1, 1).Font
If (O.Color <> .Color) And Farbe Then Ok = False
If (O.Name <> .Name) And Schriftart Then Ok = False
If (O.FontStyle <> .FontStyle) And Schriftart _
Then Ok = False
If (O.Size <> .Size) And Schriftgrad Then Ok = False
If (O.Underline <> .Underline) And _
Unterstreichung Then Ok = False
If (O.Strikethrough <> .Strikethrough) And _
Durchgestrichen Then Ok = False
If (O.Subscript <> .Subscript) And Tiefgestellt _
Then Ok = False
If (O.Superscript <> .Superscript) And _
Hochgestellt Then Ok = False
End With
End If
'Hintergrund prüfen?
If Hintergrund Then
If AC = 0 Then
Set O = R.Interior
Else
Set O = R.FormatConditions(AC).Interior
End If
With Zelle.Cells(1, 1).Interior
If (O.Color <> .Color) And Farbe Then Ok = False
If (O.Pattern <> .Pattern) And Muster Then Ok _
= False
If (O.PatternColor <> .PatternColor) And _
Musterfarbe Then Ok = False
End With
End If
'Hintergrund und/oder Vordergrund gleich?
If Ok Then
'FarbigeZellen = FarbigeZellen + 1
If FarbigeZellen Is Nothing Then
Set FarbigeZellen = R
Else
Set FarbigeZellen = Union(R, FarbigeZellen)
End If
End If
Next
End Function
#If BedingteFormatierung Then
Function ActiveCondition(Rng As Range) As Integer
'From http://www.cpearson.com/excel/CFColors.htm
'This function will return the number of the condition that _
is currently applied to the cell. If the cell does not _
have any conditional formatting defined, or none of the _
conditional formats are currently applied, it returns 0. _
Otherwise, it returns 1, 2, or 3, indicating with format _
condition is in effect.
'NOTE: ActiveCondition may result in an inaccurate result if _
the following are true:
' You are calling ActiveCondtion from a worksheet cell, AND
' The cell passed to ActiveCondtion uses a "Formula Is" _
rather than "Cell Value Is" condition, AND
' The formula used in the condition formula contains _
relative addresses
' To prevent this problem, you must use absolute cell _
address in the condition formula.
Dim Ndx As Long
Dim FC As FormatCondition
Dim Temp As Variant
Dim Temp2 As Variant
If Rng.FormatConditions.Count = 0 Then
ActiveCondition = 0
Else
For Ndx = 1 To Rng.FormatConditions.Count
Set FC = Rng.FormatConditions(Ndx)
Select Case FC.Type
Case xlCellValue
Select Case FC.Operator
Case xlBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp And _
Rng.Value <= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlGreater
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value > Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp = Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlGreaterEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlLess
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value < Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlLessEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value <= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlNotEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp <> Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlNotBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)
If IsNumeric(Temp) Then
If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) _
And (CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Not Rng.Value <= Temp And _
Rng.Value >= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case Else
Debug.Print "UNKNOWN OPERATOR"
End Select
Case xlExpression
If Application.Evaluate(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Case Else
Debug.Print "UNKNOWN TYPE"
End Select
Next Ndx
End If
ActiveCondition = 0
End Function
Function GetStrippedValue(CF As String) As String
Dim Temp As String
If InStr(1, CF, "=", vbTextCompare) Then
Temp = Mid(CF, 3, Len(CF) - 3)
If Left(Temp, 1) = "=" Then
Temp = Mid(Temp, 2)
End If
Else
Temp = CF
End If
GetStrippedValue = Temp
End Function
#End If