Option Explicit
Option Base 1
Private Type f_rec
FarbIndex As Integer
Summe As Double
End Type
Sub FarbigeZellenSummieren()
'*** 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(1 To 1)
f_cnt = 0
->den benutzten Bereich des aktiven Blattes selektieren
ActiveSheet.UsedRange.Select
->alle selektierten Zellen nacheinander bearbeiten
For Each Zelle In Selection
->Zelle farbig ?
i_Farbe = Zelle.Interior.ColorIndex
If (i_Farbe <> xlColorIndexNone) And _
(i_Farbe <> xlColorIndexAutomatic) Then
->Wert der Zelle numerisch
If IsNumeric(Zelle.Value) Then
d_Wert = Zelle.Value
->Farbe schon gemerkt
f_ind = 0
For i = 1 To f_cnt
If f(i).FarbIndex = i_Farbe Then
f_ind = 1
Exit For
End If
Next
If f_ind = 0 Then
->Farbe noch nicht gemerkt
->-> Farbe merken, Wert aufsummieren
f_cnt = f_cnt + 1
ReDim Preserve f(1 To f_cnt)
f(f_cnt).FarbIndex = i_Farbe
f(f_cnt).Summe = d_Wert
Else
->Farbe bereits gemerkt
->-> Wert aufsummieren
f(f_ind).Summe = f(f_ind).Summe + d_Wert
End If
End If
End If
Next
ActiveSheet.Cells(1, 1).Select
->keine Werte gezählt -> Ende
If f_cnt = 0 Then Exit Sub
->Ergebnis auf einem temporären Blatt ausgeben
Blattname = ActiveSheet.Name
Set ws = ActiveWorkbook.Worksheets.Add
z = 1
ws.Cells(z, 1).Value = Summen nach Farben
ws.Cells(z, 1).Font.Bold = True
z = z + 1
ws.Cells(z, 1).Value = Blatt: & Blattname
ws.Cells(z, 1).Font.Bold = True
For i = 1 To f_cnt
z = z + 1
ws.Cells(z, 1).Value = f(i).Summe
ws.Cells(z, 1).Interior.ColorIndex = f(i).FarbIndex
Next
ws.Name = tmpErG_ & Format(Now(), yymmdd_hhnnss)
Set ws = Nothing
End Sub
