693 Aufrufe
Gefragt in Windows2000 von
Hi,
Habe den Beitrag "Bedingte Formatierung zählen" gelesen. Möchte gerne bedingt
formatiert eingefärbte Zellen zählen. Habe dies auf die im Netz gängigen üblichen
Wege versucht, hat aber leider auch mit den verschiedenen VBA Codes nicht geklappt.

Bin leider kein Experte auf diesem Gebiet. VieLleicht kann mir jemand weiterhelfen. Vor
allem der Nutzer nighty scheint sich auszukennen und sehr hilfsbereit zu sein. Würde
mich freuen :).

Danke vorab!

5 Antworten

0 Punkte
Beantwortet von
Hallo ditch123,

Habe dies auf die im Netz gängigen üblichen
Wege versucht, hat aber leider auch mit den verschiedenen VBA Codes nicht geklappt.


Das dürfte daran liegen, dass die Bedingte Formatierung in den verschiedenen Excel-Versionen unterschiedlich gehandhabt wird. Welche Version hast du? Neben dem Ersatz der früheren Symbolleisten durch xmlRibbons ist das eine der größten Änderungen überhaupt für VBA.

Da du die Frage unter Rubrik Windows 2000 gepostet hast, gehe ich mal von Excel 2000 / 2003 aus. Dafür habe ich dir folgenden Code gebastelt - einzufügen in einem Standardmodul (z.B. Modul1)

Option Explicit
Function BedFormZählen(Bereich As Range, Bedform As Byte)
'für Excel 2000 und 2003
'verwendbar wenn in der bedingten Formatierung evtl. vorh. Formelnamen
'nur in Englisch verwendet wurden. z.B. SUM statt SUMME

Dim i As Long, a As Byte, b As Byte, bed As Byte
Dim appcalc As Integer
Dim tempcell As Range, c As Range

Dim w As Boolean, w1 As Boolean, w2 As Boolean
Dim counter As Long
Dim f1 As String, f2 As String
Dim op1 As String, op2 As String

Const MaxCondition = 3 'Höchstmögliche Anzahl möglicher Bedingter Formatierungen

If Bedform < 0 Or Bedform > MaxCondition Then
Application.Calculation = appcalc
BedFormZählen = "#BEZUG!"
Exit Function
Else
If Bedform = 0 Then
a = 1: b = MaxCondition
Else
a = Bedform: b = Bedform
End If
For Each c In Bereich.Cells
For bed = a To b
If bed > c.FormatConditions.Count Then Exit For
With c.FormatConditions(bed)
If .Type = 2 Then
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
Else
f1 = .Formula1
End If
ElseIf .Type = 1 Then
Select Case .Operator
Case 1: op1 = ">=": op2 = "<="
Case 2: op1 = "<": op2 = ">"
Case 3: op1 = "="
Case 4: op1 = "<>"
Case 5: op1 = ">"
Case 6: op1 = "<"
Case 7: op1 = ">="
Case 8: op1 = "<="
End Select
Select Case .Operator
Case 1 To 2
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
f2 = BezügeErweitern(.Formula2, Bereich.Parent)
Else
f1 = .Formula1
f2 = .Formula2
End If
f1 = "=" & c.Value & op1 & IIf(Left(f1, 1) = "=", Right(f1, Len(f1) - 1), f1)
f2 = "=" & c.Value & op2 & IIf(Left(f2, 1) = "=", Right(f2, Len(f2) - 1), f2)
Case 3 To 8
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
Else
f1 = .Formula1
End If
f1 = "=" & c.Value & op1 & IIf(Left(f1, 1) = "=", Right(f1, Len(f1) - 1), f1)
End Select
End If

w1 = Evaluate(f1)
If f2 <> "" Then
w2 = Evaluate(f2)
Else
w2 = True
End If
w = w1 And w2

If w = True Then
counter = counter + 1
Exit For
End If
End With
Next bed
Next c
End If

BedFormZählen = counter

End Function

Private Function IsRange(Ber As String) As Boolean
On Error Resume Next
IsRange = Range(Ber).Address <> ""
End Function
Private Function BezügeErweitern(func As String, Blatt As Worksheet) As String

'prüft ob im String ein Range-Bezug ohne Blattkennung vorhanden ist und fügt das Blatt entsprechend an.

Dim z1 As Byte, z2 As Byte, p As Long, a1 As Long, b1 As Long
Dim Zchn As Variant, a As Long, b As Long, part As String
Zchn = Array("=", "+", "-", "*", "/", "^", "(", ")", Application.International(xlListSeparator))

p = 1
a1 = Len(func): b1 = Len(func)
For z1 = 0 To UBound(Zchn)
a = InStr(p, func, Zchn(z1))
If a <> 0 And a < a1 Then a1 = a
Next z1
a = a1
p = p + 1
Do
b1 = Len(func)
For z2 = 0 To UBound(Zchn)
b = InStr(p, func, Zchn(z2))
If b <> 0 And b < b1 Then b1 = b
Next z2
b = b1
If a = b Then a = 0
part = Mid(func, a + 1, b - a - IIf(b = Len(func), 0, 1))
If IsRange(part) Then
If InStr(1, part, "!") = 0 Then
func = Replace(func, part, Blatt.Name & "!" & part)
b = b + Len(Blatt.Name) + 1
End If
End If

p = b + 1
a = b
Loop Until p > Len(func)

BezügeErweitern = func
End Function
Um nun zu zählen gibst du im Excel z.B. die Formel
=BedFormZählen(Tabelle1!B9:B26;0) ein. Wenn sich die Zellen und die Formel auf dem gleichen Blatt befinden, kannst du Tabelle1! auch weglassen. Der zweite Parameter gibt an, für welche der 3 möglichen bedingten Formatierungen geprüft werden soll, ob sie zutrifft. Wenn du hier 0 eingiebst werden alle 3 geprüft.

Gruß Mr. K.
0 Punkte
Beantwortet von
Leider geht die Rückgabe per Excel-Formel nur, wenn die abgefragten Bedingten Formatierungen keine Deuschsprachigen Formeln (z.B. SUMME statt SUM) enthalten. Da ich keine Lust habe sämtliche möglichen Formeln zu übersetzen vom Code ersetzen zu lassen, hier noch eine leicht abgewandelte Alternative über ein normales Makro, welches du wie gewohnt z.B. über ein Symbol oder einen Button ausführen kannst.

Das kannst du ja in Modul2 einfügen.
Sub BedFormZählenExt()
'für Excel 2000 und 2003
'verwendbar wenn in der bedingten Formatierung evtl. vorh. Formelnamen
'nur in Englisch verwendet wurden. z.B. SUM statt SUMME

Dim i As Long, a As Byte, b As Byte, bed As Byte
Dim appcalc As Integer, r As String, Bereich As Range, Bedform As Byte
Dim tempcell As Range, c As Range

Dim w As Boolean, w1 As Boolean, w2 As Boolean
Dim counter As Long
Dim f1 As String, f2 As String
Dim op1 As String, op2 As String

Const MaxCondition = 3 'Höchstmögliche Anzahl möglicher Bedingter Formatierungen

Do
r = InputBox("Geben Sie einen Bereich ein", "Zellen mit bedingter Formatierung zählen", "A1:B12")
Loop Until IsRange(r)
Set Bereich = Range(r)
Bedform = InputBox("Geben Sie eine Zahl von 0 bis 3 ein" & Chr(13) & _
"0 = Zellen zählen auf die mindestens Eine der drei Bedingten Formatierungen zutrifft" & Chr(13) & _
"1 = Zellen zählen auf die die Erste Bedingte Formatierung zutrifft" & Chr(13) & _
"2 = Zellen zählen auf die die Zweite Bedingte Formatierung zutrifft" & Chr(13) & _
"3 = Zellen zählen auf die die Dritte Bedingte Formatierung zutrifft" & Chr(13))

appcalc = Application.Calculation
Application.Calculation = xlCalculationManual

Set tempcell = Bereich.Parent.UsedRange.SpecialCells(xlLastCell)
If tempcell.Row < Bereich.Parent.Rows.Count Then
Set tempcell = tempcell.Offset(1, 0)
End If
tempcell.Font.Color = tempcell.Interior.Color

If Bedform < 0 Or Bedform > MaxCondition Then
MsgBox "Bitte geben Sie eine gültige Position einer bedingten Formatierung an"
Application.Calculation = appcalc
Exit Sub
Else
If Bedform = 0 Then
a = 1: b = MaxCondition
Else
a = Bedform: b = Bedform
End If
For Each c In Bereich.Cells
For bed = a To b
If bed > c.FormatConditions.Count Then Exit For
With c.FormatConditions(bed)
If .Type = 2 Then
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
Else
f1 = .Formula1
End If
ElseIf .Type = 1 Then
Select Case .Operator
Case 1: op1 = ">=": op2 = "<="
Case 2: op1 = "<": op2 = ">"
Case 3: op1 = "="
Case 4: op1 = "<>"
Case 5: op1 = ">"
Case 6: op1 = "<"
Case 7: op1 = ">="
Case 8: op1 = "<="
End Select
Select Case .Operator
Case 1 To 2
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
f2 = BezügeErweitern(.Formula2, Bereich.Parent)
Else
f1 = .Formula1
f2 = .Formula2
End If
f1 = "=" & c.Value & op1 & IIf(Left(f1, 1) = "=", Right(f1, Len(f1) - 1), f1)
f2 = "=" & c.Value & op2 & IIf(Left(f2, 1) = "=", Right(f2, Len(f2) - 1), f2)
Case 3 To 8
If ActiveSheet.Name <> Bereich.Parent.Name Then
f1 = BezügeErweitern(.Formula1, Bereich.Parent)
Else
f1 = .Formula1
End If
f1 = "=" & c.Value & op1 & IIf(Left(f1, 1) = "=", Right(f1, Len(f1) - 1), f1)
End Select
End If

If Application.ReferenceStyle = xlA1 Then
tempcell.FormulaLocal = f1
ElseIf Application.ReferenceStyle = xlR1C1 Then
tempcell.FormulaR1C1Local = f1
End If
tempcell.Calculate
w1 = tempcell.Value

If f2 <> "" Then
If Application.ReferenceStyle = xlA1 Then
tempcell.FormulaLocal = f2
ElseIf Application.ReferenceStyle = xlR1C1 Then
tempcell.FormulaR1C1Local = f2
End If
tempcell.Calculate
w2 = tempcell.Value
Else
w2 = True
End If

w = w1 And w2

If w = True Then
counter = counter + 1
Exit For
End If
End With
Next bed
Next c
End If

MsgBox counter & " Zellen wurden bedingt formatiert"
Application.Calculation = appcalc

End Sub

Private Function IsRange(Ber As String) As Boolean
On Error Resume Next
IsRange = Range(Ber).Address <> ""
End Function
Private Function BezügeErweitern(func As String, Blatt As Worksheet) As String

'prüft ob im String ein Range-Bezug ohne Blattkennung vorhanden ist und fügt das Blatt entsprechend an.

Dim z1 As Byte, z2 As Byte, p As Long, a1 As Long, b1 As Long
Dim Zchn As Variant, a As Long, b As Long, part As String
Zchn = Array("=", "+", "-", "*", "/", "^", "(", ")", Application.International(xlListSeparator))

p = 1
a1 = Len(func): b1 = Len(func)
For z1 = 0 To UBound(Zchn)
a = InStr(p, func, Zchn(z1))
If a <> 0 And a < a1 Then a1 = a
Next z1
a = a1
p = p + 1
Do
b1 = Len(func)
For z2 = 0 To UBound(Zchn)
b = InStr(p, func, Zchn(z2))
If b <> 0 And b < b1 Then b1 = b
Next z2
b = b1
If a = b Then a = 0
part = Mid(func, a + 1, b - a - IIf(b = Len(func), 0, 1))
If IsRange(part) Then
If InStr(1, part, "!") = 0 Then
func = Replace(func, part, Blatt.Name & "!" & part)
b = b + Len(Blatt.Name) + 1
End If
End If

p = b + 1
a = b
Loop Until p > Len(func)

BezügeErweitern = func
End Function

Gruß Mr. K.
0 Punkte
Beantwortet von
Die Makrovariante funktioniert natürlich mit Deutschen Formeln (bzw. Formeln in Landessprache) in den Bedingten Formatierungen. Habe nur vergessen die Beschreibung zu Beginn des Makros zu ändern.

Habe beide Varianten heute ausgiebig getestet. Solltest du dennoch irgendwelche Bugs entdecken, sag Bescheid.

Mr K.
0 Punkte
Beantwortet von
Übrigens kannst du in der Excel-Formel den zweiten Parameter auch weglassen wenn du in Antwort 1 die Zeile
Function BedFormZählen(Bereich As Range, Bedform As Byte)
durch
Function BedFormZählen(Bereich As Range, Optional Bedform As Byte)
ersetzt
0 Punkte
Beantwortet von
Ähem,
eine Kleinigkeit hab ich jetzt doch noch entdeckt:
Ersetze die Zeile
Zchn = Array("=", "+", "-", "*", "/", "^", "(", ")", Application.International(xlListSeparator))
durch
Zchn = Array("=", "+", "-", "*", "/", "^", "<>", ">", "<", "(", ")", Application.International(xlListSeparator))
um wirklich Alle Operatoren zu berücksichtigen.
...