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.