title image


Smiley Bin in anderem Forum fündig geworden - für alle die es interssiert
'=ZÄHLENWENN(A1:H1;"U") - (Farbe(A1:H1;33)+Farbe(A1:H1;3))



Function Farbe(rngBereich As Object, intColor As Integer)

Dim intCounter As Integer

Dim rngAct As Range

Dim x%



For Each rngAct In rngBereich

x = GetCellColor(rngAct)

If x = intColor And _

rngAct.Text = "U" Then

intCounter = intCounter + 1

End If

Next rngAct

Farbe = intCounter

End Function



Function GetCellColor(cell As Range) As Integer

' Von Bernd bstrohhaecker@gmx.de

Dim i

Dim myVal

Dim myColor As Integer

Dim done As Boolean



On Error Resume Next

Names("testname").Delete

On Error GoTo 0



Application.ReferenceStyle = xlR1C1

myVal = cell.Value

myColor = cell.Interior.ColorIndex

done = False



For i = 1 To cell.FormatConditions.Count

With cell.FormatConditions.Item(i)

If .Type = 1 Then

Select Case .Operator

Case xlBetween

If myVal >= Evaluate(.Formula1) And myVal <= Evaluate(.Formula2) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlEqual

If myVal = Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlGreater

If myVal > Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlGreaterEqual

If myVal >= Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlLess

If myVal < Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlLessEqual

If myVal <= Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlNotBetween

If myVal Evaluate(.Formula2) Then

myColor = .Interior.ColorIndex

done = True

End If

Case xlNotEqual

If myVal Evaluate(.Formula1) Then

myColor = .Interior.ColorIndex

done = True

End If

End Select

ElseIf .Type = 2 Then

Names.Add Name:="testname", RefersToR1C1Local:=.Formula1

If Evaluate("testname") Then

myColor = .Interior.ColorIndex

done = True

End If

Names("testname").Delete

Else

MsgBox "Unbekannter Typ: " & .Type, , "PANIC: In Function GetCellColor"

Exit Function

End If

End With

If done Then Exit For

Next

Application.ReferenceStyle = xlA1

GetCellColor = myColor

End Function





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: