Wenn das Quellblatt ( hier Tabelle1 ) beispielsweise wie oben gezeigt aussieht, wird folgendes Ergebnis auf dem Tabellenblatt "Farbe" ausgegeben.
In Spalte A erscheint die Farbe
In Spalte B die Anzahl der Zellen mit dieser Farbgebung
in Spalte C die Summe der Zellen mit dieser Farbgebung, wenn sie einen numerischen Wert enthalten.
Der Code:
Public Sub Farbige_Zellen_zaehlen_und_addieren()
'Code für ein allgemeines Modul
'*********************************
'Autor: Jürgen Hennekes
'*********************************
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngC(1 To 56) As Long
Dim dblSumme(1 To 56) As Double
Dim Zelle As Range
Dim lngZ As Long
Dim i As Integer
Dim bln As Boolean
'Prüfen ob Tabellenblatt "Farbe" existiert
For i = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(i).Name = "Farbe" Then
bln = True
Exit For
End If
Next
If bln = False Then
MsgBox "Das Tabellenblatt [ Farbe ] existiert noch nicht" & vbCr _
& "Bitte zunächst anlegen.", 64
Exit Sub
End If
'Wertzuweisung Variable
Set wksQ = Worksheets("Tabelle1") 'Quellblatt ( Blattname bitte anpassen )
Set wksZ = Worksheets("Farbe") 'Zielblatt ( Tabelle bitte anlegen )
lngZ = 2
'Zählen bzw Addition der farbigen Zellen
For Each Zelle In wksQ.UsedRange
If Zelle.Interior.ColorIndex > 0 Then
lngC(Zelle.Interior.ColorIndex) = lngC(Zelle.Interior.ColorIndex) + 1
If IsNumeric(Zelle.Value) Then
dblSumme(Zelle.Interior.ColorIndex) = dblSumme(Zelle.Interior.ColorIndex) + Zelle.Value
End If
End If
Next
'Zielbereich löschen ( Altdaten ) und Header eintragen
With wksZ
.UsedRange.Clear
.Cells(1, 1).Value = "Farbe"
.Cells(1, 2).Value = "Anzahl"
.Cells(1, 3).Value = "Summe"
' Ergebnisse übertragen nach Tabelle "Farbe"
For i = 1 To 56
If lngC(i) > 0 Then
.Cells(lngZ, 1).Interior.ColorIndex = i
'.Cells(lngZ, 1).Value = i ' Auf Wunsch wird die Farb-Nr geschrieben
.Cells(lngZ, 2).Value = lngC(i)
.Cells(lngZ, 3).Value = dblSumme(i)
lngZ = lngZ + 1
End If
Next
End With
'Wechsel nach Tabellenblatt "Farbe"
wksZ.Activate
End Sub
|
||||||
