Farben zählen bei bedingter Formatierung

Hallo EXCEL-Freunde,
aus dem Forum habe ich nachstehende Codes, mit denen man Zellen zählen kann,
die einen farblichen Hintergrund haben. Wenn der farbliche Hintergrund aller-
dings durch eine bedingte Formatierung zustande kommt, gehts nicht.
Gibts für eine Farbenzählung mit bedingter Formatierung vielleicht auch ein Lösung?
Option Explicit
' von Melanie Breden und Thomas Ramel
' Anzahl der Zellen mit einer Farbe
Function CountColor(Farbe As Range, ParamArray rngArea()) As Double
Dim rngCell As Range
Dim varArea As Variant
Dim intColor As Integer
intColor = Farbe(1).Interior.ColorIndex
Application.Volatile
For Each varArea In rngArea
For Each rngCell In varArea
If rngCell.Interior.ColorIndex = intColor Then
CountColor = CountColor + 1
End If
Next
Next
End Function
'Im Tabellenblatt dann einfach den folgenden Aufruf:
'=CountColor(A1;$C$1:$C$12)
' Melanie Breden
'Hast du getrennte Bereiche, führe sie durch Simikolons getrennt auf:
'=CountColor(3;A1:A10;C1:C10)
' Anzahl der Zellen mit einer Farbe
' In Zelle=Farbsumme(A1:A10;3)
Function FarbsummeHA(Bereich As Range, Farbe As Integer)
' Hintergrund
Dim Zelle
Application.Volatile
For Each Zelle In Bereich
If Zelle.Interior.ColorIndex = Farbe Then
FarbsummeHA = FarbsummeHA + 1
End If
Next
End Function

Besten Dank für eine Hilfe!
mfg
Erich
EXCEL-Shareware und Freeware: http://www.toolex.de
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Erich,
ich habe mal folgenden Code in einem Forum gefunden und nicht weiter getestet.
Sub MachWas() Dim Zelle As Range: Zeile = 1 For Each Zelle In Worksheets("Tabelle1").UsedRange If Zelle.Interior.ColorIndex = 3 Then Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile) Zeile = Zeile + 1 ' Format, Muster Zellen ElseIf Cells(Zelle.Row, Zelle.Column).FormatConditions.Parent.Interior.ColorIndex = 3 Then Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile) Zeile = Zeile + 1 ' bedingte Formatierung erkennen ' noch fehlerhaft es werden alle Zellen kopiert die bei bedingte Formatierung den Hintergrund rot(3) ' färben sollen auch wenn nicht erfüllt ElseIf Cells(Zelle.Row, Zelle.Column).FormatConditions.Item(1).Interior.ColorIndex = 3 Then Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile) Zeile = Zeile + 1 End If Next Zelle End Sub


Sub test()
'   von JensF
Dim OP As Long
Dim Formel As Long
Dim Farbe As Long
Dim Z As Range
Dim Erfüllt As Boolean
Set Z = ActiveCell
Formel = Z.FormatConditions(1).Formula1
OP = Z.FormatConditions(1).Operator
Select Case OP
Case xlGreater
Erfüllt = (Z.Value > Formel)
Case xlGreaterEqual
Erfüllt = (Z.Value >= Formel)
Case xlLessEqual
Erfüllt = (Z.Value <= Formel)
Case xlLess
Erfüllt = (Z.Value < Formel)
End Select
If Erfüllt Then
MsgBox Z.FormatConditions.Item(1).Interior.ColorIndex
Else
MsgBox Z.Font.ColorIndex
End If
End Sub


Sub MachWas2()
Dim Zelle As Range
Dim Formel As Long
Dim Z As Range
Dim Erfüllt As Boolean
Zeile = 1
For Each Zelle In Worksheets("Tabelle1").UsedRange
If Zelle.Interior.ColorIndex = 3 Then
Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile)
Zeile = Zeile + 1
'       Format, Muster Zellen
ElseIf Cells(Zelle.Row, Zelle.Column).FormatConditions.Parent.Interior.ColorIndex = 3 Then
Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile)
Zeile = Zeile + 1
'       bedingte Formatierung erkennen
'       noch fehlerhaft es werden alle Zellen kopiert die bei bedingte Formatierung den Hintergrund rot(3)
'       färben sollen auch wenn nicht erfüllt
ElseIf Cells(Zelle.Row, Zelle.Column).FormatConditions.Item(1).Interior.ColorIndex = 3 Then
Set Z = Cells(Zelle.Row, Zelle.Column)
Formel = Z.FormatConditions(1).Formula1
OP = Z.FormatConditions(1).Operator
Select Case OP
Case xlGreater
Erfüllt = (Z.Value > Formel)
Case xlGreaterEqual
Erfüllt = (Z.Value >= Formel)
Case xlLessEqual
Erfüllt = (Z.Value <= Formel)
Case xlLess
Erfüllt = (Z.Value < Formel)
End Select
If Erfüllt Then
Worksheets("Tabelle1").Rows(Zelle.Row).Copy Destination:=Worksheets("Tabelle2").Range("A" & Zeile)
Zeile = Zeile + 1
End If
End If
Next Zelle
End Sub

Gruss Harald

Beliebteste Forumthreads (12 Monate)

Farben zählen bei bedingter Formatierung

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Farben zählen bei bedingter Formatierung

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread