AW: Farbsumme
06.07.2005 10:59:44
Rocky
hat sich erledigt,
im editor hatte sich noch dies versteckt:
Function CountByCFColorIndex(Rng As Range, CI As Integer) As Long
Dim R As Range
Dim Total As Long
For Each R In Rng.Cells
If ColorIndexOfCF(R, False) = CI Then
Total = Total + 1
End If
Next R
CountByCFColorIndex = Total
End Function
Function ActiveCondition(Rng As Range) As Integer
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 ColorIndexOfCF(Rng As Range, _
Optional OfText As Boolean = False) As Integer
Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
If OfText = True Then
ColorIndexOfCF = Rng.Font.ColorIndex
Else
ColorIndexOfCF = Rng.Interior.ColorIndex
End If
Else
If OfText = True Then
ColorIndexOfCF = Rng.FormatConditions(AC).Font.ColorIndex
Else
ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex
End If
End If
End Function
'''''''''''''''''''''''''''''''''''''''
Function ColorOfCF(Rng As Range, Optional OfText As Boolean = False) As Long
Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
If OfText = True Then
ColorOfCF = Rng.Font.Color
Else
ColorOfCF = Rng.Interior.Color
End If
Else
If OfText = True Then
ColorOfCF = Rng.FormatConditions(AC).Font.Color
Else
ColorOfCF = Rng.FormatConditions(AC).Interior.Color
End If
End If
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
'''''''''''''''''''''''''''''''''''''''
Function CountOfCF(InRange As Range, _
Optional Condition As Integer = -1) As Long
Dim Count As Long
Dim Rng As Range
Dim FCNum As Integer
For Each Rng In InRange.Cells
FCNum = ActiveCondition(Rng)
If FCNum > 0 Then
If Condition = -1 Or Condition = FCNum Then
Count = Count + 1
End If
End If
Next Rng
CountOfCF = Count
End Function
'''''''''''''''''''''''''''''''''''''''
Function SumByCFColorIndex(Rng As Range, CI As Integer) As Double
Dim R As Range
Dim Total As Double
For Each R In Rng.Cells
If ColorIndexOfCF(R, False) = CI Then
Total = Total + R.Value
End If
Next R
SumByCFColorIndex = Total
End Function
gruß Rocky