Nachtrag: Alle farbigen Zellen addieren
09.08.2006 15:26:28
bst
Hallo,
mir ist da leider ein ziemlich dummer Fehler unterlaufen.
Die hier gepostete Version ist auch ein älteres Teil und enthält zudem noch einen Fehler.
Der Trick mit dem Übersetzen der Formel mit Hilfe eines Namens funktioniert hier nicht.
Dieses wird zwar dann (meistens) im 2. Versuch korrigiert, ist aber trotzdem daneben :-(
Anbei die aktuelle Version, die leider immer noch nicht alle Fälle erschlägt ...
Diese findet sich übrigens auch hier: http://home.media-n.de/ziplies/
Sorry und mea culpa,
Bernd
--
Option Explicit
Sub Test_aktuelle_Zelle()
MsgBox GetCFColor(ActiveCell), vbInformation, "Die Farbe der Zelle ist"
End Sub
Function GetCFColor(cell As Range, Optional OfText As Boolean = False) As Integer
Dim CFCond As Integer
' Defaultwert festlegen
GetCFColor = IIf(OfText, cell.Font.ColorIndex, cell.Interior.ColorIndex)
CFCond = GetCFCondition(cell)
If CFCond Then
If OfText Then
' hmm, falls niemals solch ein Teil zugewiesen wurde steht hier halt noch NULL
On Error Resume Next
GetCFColor = cell.FormatConditions(CFCond).Font.ColorIndex
On Error GoTo 0
Else
GetCFColor = cell.FormatConditions(CFCond).Interior.ColorIndex
End If
End If
End Function
Function GetCFCondition(cell As Range) As Integer
Dim mycell As Range
Dim myVal, myVal_1, myVal_2
Dim i As Integer
Dim done As Boolean
GetCFCondition = 0
Set mycell = cell(1) ' falls es mehrere Zellen sind, die 1. davon nehmen
mycell.Select ' der muß wohl leider sein, :-(
myVal = mycell.Value ' Der Wert der Zelle
For i = 1 To cell.FormatConditions.Count
With cell.FormatConditions.Item(i)
myVal_1 = GetCFVal(mycell, cell.FormatConditions.Item(i), False)
If .Type = 1 Then
If .Operator = xlBetween Or .Operator = xlNotBetween Then _
myVal_2 = GetCFVal(mycell, cell.FormatConditions.Item(i), True)
End If
' Hier erfolgt dann die eigentliche Unterscheidung
If .Type = 1 Then
Select Case .Operator
Case xlBetween
done = (myVal >= myVal_1 And myVal <= myVal_2) Or _
(myVal >= myVal_2 And myVal <= myVal_1)
Case xlEqual
done = myVal = myVal_1
Case xlGreater
done = myVal > myVal_1
Case xlGreaterEqual
done = myVal >= myVal_1
Case xlLess
done = myVal < myVal_1
Case xlLessEqual
done = myVal <= myVal_1
Case xlNotBetween
done = (myVal < myVal_1 And myVal < myVal_2) Or _
(myVal > myVal_1 And myVal > myVal_2)
Case xlNotEqual
done = myVal <> myVal_1
Case Else
MsgBox "Unbekannter Operator: " & .Operator, , "PANIC: In Function GetCFCondition"
Exit Function
End Select
ElseIf .Type = 2 Then
done = myVal_1 = True
Else
MsgBox "Unbekannter Typ: " & .Type, , "PANIC: In Function GetCFCondition"
Exit Function
End If
On Error GoTo 0
If done Then ' wir haben fertig
GetCFCondition = i
Exit Function
End If
End With
Next
End Function
'
' Versucht den Wert der Formel der bedingten Formatierung (CF) zu bestimmen.
'
' Das funktioniert aber NICHT immer !!!
'
' Zuerst wird einfach die Formel via Cdbl() zugewiesen. Das funktioniert nur für
' ganz normale Zahlen, welche in der CF als String abgelegt sind, z.B.: als "1"
'
' Danach wird versucht mit Evaluate die Formel zu berechnen. Falls das auch nicht
' geht wird die Formel der bedingten Formatierung in die Zellformel kopiert
' und dieses ausgewertet
'
' Evaluate() funktioniert wohl nicht mit relativen Bezügen in anderen Namen, ZEILE(), SPALTE(), etc. ?
'
' Bsp für Namen: Setze Cursor nach B2, definiere abc als =A1 (OHNE $ !), schreibe in Zelle D4 =abc
' und schaue von dort aus mal nach wie denn abc definiert ist. Man tue sowas mal in eine CF-Formel.
'
' triviale Beispiele für Zeile/Spalte: =ZEILE() bzw =SPALTE(A6), beide gehen schon nicht.
' Funny, da hätte ich auch bereits früher draufkommen können, Zeile() bzw Spalte
' liefern ein Array zurück ;-) Entweder 1 oder 2 dimensional ...
'
' Das Umbiegen der CF-Formel in die Zellen-Formel geht nicht immer gut.
' Ein mögliches Problem ist hier das Entstehen eines Zirkelbezuges
'
' Beispiel:
' Formel in Zelle A13: =UNTEN, CF in Zelle A14: Zellwert ist gleich: =OBEN
' wobei OBEN und UNTEN jeweils relativ definierte Namen sind, die auf die
' entsprechende Zelle weisen, d.h. mit aktiver Zelle A2:
' OBEN: =Tabelle1!A1 sowie UNTEN: =Tabelle1!A3
'
' Böse Falle, man kann hier NICHT formula als String übergeben, da dann der Trick
' mit dem Übersetzen via Name hier nicht mehr funktioniert !!!
'
Function GetCFVal(mycell As Range, fc As FormatCondition, bUseFC2 As Boolean) As Variant
Dim ev, f$, fa$, myVal
On Error Resume Next
' 1. Versuch, der geht wenn's denn eine Zahl ist, z.B.: "1.2"
If bUseFC2 Then
ev = CDbl(fc.Formula2)
Else
ev = CDbl(fc.Formula1)
End If
If TypeName(ev) = "Double" Then
GetCFVal = ev
Exit Function
End If
' 2. Versuch via Evaluate(Name)
' Durch die nächsten 2. Zeilen wird die Deutsche Formel der CF ins Englische übersetzt !
Application.ReferenceStyle = xlR1C1
If bUseFC2 Then
Names.Add Name:="cfTestName", RefersToR1C1Local:=fc.Formula2
Else
Names.Add Name:="cfTestName", RefersToR1C1Local:=fc.Formula1
End If
' und jetzt - mit englischer Formel in cfTestName geht Evaluate - nun ja - vielleicht ...
ev = Evaluate("cfTestName")
Names("cfTestName").Delete
Application.ReferenceStyle = xlA1
Select Case TypeName(ev) ' ist wohl aus der Kategorie dubios ;-)
Case "Variant()": ' Ein Array, schaun wir mal in ev(1)
ev = ev(1)
If TypeName(ev) = "Variant()" Then
GetCFVal = ev(1, 1)
Else
GetCFVal = ev
End If
Case "Error", "Empty": ' Es hat wohl nicht funktioniert, 3. Versuch
myVal = mycell.Value
If mycell.HasArray Then
fa = mycell.FormulaArray
f = ""
Else
fa = ""
f = mycell.Formula
End If
mycell.Formula = "" ' der macht manchmal schon Sinn
If bUseFC2 Then
mycell.FormulaLocal = fc.Formula2
Else
mycell.FormulaLocal = fc.Formula1
End If
GetCFVal = mycell.Value ' Es gibt zwar noch Hoffnung, aber ... :-(
' Falls dieses denn nicht funktionierte, fehlt mir's an Ideen ::--(
If fa = "" Then
mycell.Formula = f
Else
mycell.FormulaArray = fa
End If
Case Else: GetCFVal = ev ' Hurra, es hat funktioniert :-)
End Select
On Error GoTo 0
End Function
Function FarbeZählen(Bereich As Range, Farbe As Byte) As Long
Dim RaC As Range
For Each RaC In Bereich
If GetCFColor(RaC) = Farbe Then
FarbeZählen = FarbeZählen + 1
End If
Next RaC
End Function
Function FARBSumme(Bereich As Range, Farbe As Byte) As Long
Dim RaC As Range
For Each RaC In Bereich
If GetCFColor(RaC) = Farbe Then
FARBSumme = FARBSumme + RaC.Value
End If
Next RaC
End Function