AW: Hintergrundfarbe bei bedingter Formatierung
18.05.2005 14:10:45
bst
Hallo Ede,
evaluate() scheint nur mit englischen Formeln zurechtzukommen. In der bedingten
Formatierung stehen aber - IMHO dummerweise - lokalisierte Formeln drinne.
Deshalb geht das so wohl nicht :-(
Mir ist bisher nur der Umweg über Namen eingefallen.
D.h. aber daß es nicht als UDF benutzt werden kann.
Vielleicht hat ja jemand noch was besseres...
Übrigens, Formeln können auch in 'normalen' Bedingungen stehen.
HTH, Bernd
--
Option Explicit
Sub TestCellColor()
MsgBox GetCellColor(ActiveCell), , "Meine Füllfarbe ist:"
End Sub
Sub TestTextColor()
MsgBox GetCellColor(ActiveCell, True), , "Meine Textfarbe ist:"
End Sub
Function GetCellColor(cell As Range, Optional OfText As Boolean = False) As Integer
Dim myVal, eval_1, eval_2
Dim i As Integer
Dim done As Boolean
If OfText Then ' Default ist die Textfarbe der Zelle
GetCellColor = cell.Font.ColorIndex
Else ' Default ist die Füllfarbe der Zelle
GetCellColor = cell.Interior.ColorIndex
End If
myVal = cell.Value ' Der Wert der Zelle
For i = 1 To cell.FormatConditions.Count
With cell.FormatConditions.Item(i)
' Anders habe ich es nicht hinbekommen!
' Den ReferenceStyle mußte ich umbiegen damit
' Names.Add RefersToR1C1Local & Evalute funktionieren
' ein simples Evaluate(.Formula1) SCHEITERT, falls dort
' eine Formel mit Namen steht, z.B.: SUMME
' dieser Name ist hier nämlich lokalisiert, evaluate selber
' funktioniert aber nur mit englischem SUM !!!
Application.ReferenceStyle = xlR1C1
'cell.FormulaLocal = .Formula1
On Error Resume Next
Names.Add Name:="testname_1", RefersToR1C1Local:=.Formula1
Names.Add Name:="testname_2", RefersToR1C1Local:=.Formula2
eval_1 = Evaluate("testname_1")
eval_2 = Evaluate("testname_2")
Names("testname_1").Delete
Names("testname_2").Delete
On Error GoTo 0
Application.ReferenceStyle = xlA1
' Hier erfolgt dann die eigentliche Unterscheidung
If .Type = 1 Then
Select Case .Operator
Case xlBetween
done = (myVal >= eval_1 And myVal <= eval_2) Or _
(myVal >= eval_2 And myVal <= eval_1)
Case xlEqual
done = myVal = eval_1
Case xlGreater
done = myVal > eval_1
Case xlGreaterEqual
done = myVal >= eval_1
Case xlLess
done = myVal < eval_1
Case xlLessEqual
done = myVal <= eval_1
Case xlNotBetween
done = (myVal < eval_1 And myVal < eval_2) Or _
(myVal > eval_1 And myVal > eval_2)
Case xlNotEqual
done = myVal <> eval_1
Case Else
MsgBox "Unbekannter Operator: " & .Operator, , "PANIC: In
Function GetCellColor"
Exit Function
End Select
ElseIf .Type = 2 Then
done = eval_1 = True
Else
MsgBox "Unbekannter Typ: " & .Type, , "PANIC: In
Function GetCellColor"
Exit Function
End If
If done Then ' wir haben fertig
If OfText Then
GetCellColor = xlColorIndexNone
' hmm, falls niemals solch ein Teil zugewiesen wurde
' steht hier halt noch NULL
On Error Resume Next
GetCellColor = .Font.ColorIndex
On Error GoTo 0
Else
GetCellColor = .Interior.ColorIndex
End If
Exit Function
End If
End With
Next
End Function