title image


Smiley Verweis von Boris aus excelhost:
aus excelhost



Option Explicit



Function GetCellColor(cell As Range) As Integer

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

' Original von Bernd

' Case xlBetween

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

' myColor = .Interior.ColorIndex

' done = True

' End If

' Veränderung von Simon Hirsbrunner

Case xlBetween

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

Or (myVal = Evaluate(.Formula2)) Then

'Das fehlt meiner Meinung nach noch (OR), sonst muss Formula1 immer der

'grössere Wert der Schranke sein (Was wenn Formula1 = 5 und Formula2

'= 2 -> der xlBetween gibt nichts zurück. (Rest wieder Standart)

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



Function FARBEZÄHLEN(Bereich As Range, Farbe As Byte) As Long

Dim RaC As Range

For Each RaC In Bereich

' Veränderung von Unimatrix Zero

If GetCellColor(RaC) = Farbe Then

' *************

FARBEZÄHLEN = FARBEZÄHLEN + 1

End If

Next RaC

End Function



Sub Test()

MsgBox FARBEZÄHLEN(ThisWorkbook.Sheets(1).Range("A1:A9"), 4)

End Sub







wird das über das Makro Test aufgerufen kommt das richtige Ergebnis, aber in der Tabelle über die Funktion wird bei der markierten Zeile der Code abgebrochen.




Gruß

Wolli     danke für eure Fragen, so weiß ich, daß ich nichts weiß...

geschrieben von


Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: