Hallo
Ich hoffe ich konnte auch x helfen ...
Gruß
Werner
Option Explicit
Option Base 1
Private Type f_rec
FarbIndex As Integer
Summe As Double
End Type
Sub Schaltfläche272_BeiKlick()
'*** bildet die Summe über die numerischen Werte aller farbigen Zellen pro Farbe und gibt das Ergebnis auf einem temp. Arbeitsblatt aus.
'*** (nicht betrachtet werden Zellen, die den Colorindex xlColorIndexNone oder xlColorIndexAutomatic haben)
Dim f() As f_rec, f_cnt As Integer, f_ind As Integer
Dim Zelle As Range, Blattname As String, ws As Worksheet
Dim i_Farbe As Integer, d_Wert As Double, i As Integer
Dim z As Long
ReDim f(6)
'den benutzten Bereich des aktiven Blattes selektieren
ActiveSheet.Range("h8: FS8").Select ' Zellen selektieren"
'den jeweiligen Farbzähler auf 0 setzen
f(1).Summe = 0 ' Rot
f(2).Summe = 0 ' grün
f(3).Summe = 0 ' gelb
f(4).Summe = 0 ' schartz
f(5).Summe = 0 '
f(6).Summe = 0 '
'alle selektierten Zellen nacheinander bearbeiten
For Each Zelle In Selection
'abfrage nach Zellenfarbe?
i_Farbe = Zelle.Interior.ColorIndex
If (i_Farbe = 3) Then f(1).Summe = f(1).Summe + 1
If (i_Farbe = 4) Then f(2).Summe = f(2).Summe + 1
If (i_Farbe = 6) Then f(3).Summe = f(3).Summe + 1
If (i_Farbe = 1) Then f(4).Summe = f(4).Summe + 1
If Not ((i_Farbe = 2) Or (i_Farbe = 3) Or (i_Farbe = 4)) Or (i_Farbe = 1) Then f(6).Summe = f(6).Summe + 1
Next
ActiveSheet.Cells(1, 1).Select
ActiveSheet.Cells(8, 1).Value = f(1).Summe ' Rot
ActiveSheet.Cells(8, 2).Value = f(2).Summe ' grün
ActiveSheet.Cells(8, 3).Value = f(3).Summe ' gelb
ActiveSheet.Cells(8, 4).Value = f(4).Summe ' schartz
ActiveSheet.Cells(8, 5).Value = f(6).Summe ' rest
End Sub
|