AW: Teilergebnisse, Summe aus Zellfarben
28.08.2009 16:39:02
fcs
Hallo Chris,
hier meine beiden VBA-Lösungen.
Gruß
Franz
Lösung 1 generiert Teilergebnis-Formeln
Option Explicit
'Variablendeklaration
Private ws As Worksheet, lZeile As Long
Private ZeileEnde As Long, ZeileStart As Long, ZeileLetzte As Long
Private Const lSpalteText As Long = 1
Private Const lSpalteFormel As Long = 2
Private Const Zeile_1 As Long = 5 '1. Zeile mit Werten
'Colorindex der zu vergleichenden Farben
Private Const Farbe_1 As Long = 45 'Farbe der obersten Ebene, Ebene 1
Private Const Farbe_2 As Long = 44 'Farbe Ebene 2
Private Const Farbe_3 As Long = 40 'Farbe Ebene 3
Private Const Farbe_4 As Long = 6 'Farbe Ebene 4
Private Const Farbe_5 As Long = 36 'Farbe Ebene 5
Private Const Farbe_6 As Long = 0 'Farbe der untersten Ebene oder ohne Füllfarbe, Ebene 6
Sub TeilergebnisformelnEinfuegen()
'Fügt auf Basis der Zellfarben Teilergebnis-Summenformeln ein
Set ws = ActiveSheet
With ws
ZeileLetzte = .Cells(.Rows.Count, lSpalteText).End(xlUp).Row
End With
'Summenformeln Ebene 5 einfügen
Call TeilErgebnis(Farbe:=Farbe_5)
'Summenformeln Ebene 4 einfügen
Call TeilErgebnis(Farbe:=Farbe_4)
'Summenformeln Ebene 4 einfügen
Call TeilErgebnis(Farbe:=Farbe_3)
'Summenformeln Ebene 4 einfügen
Call TeilErgebnis(Farbe:=Farbe_2)
'Summenformeln Ebene 4 einfügen
Call TeilErgebnis(Farbe:=Farbe_1)
End Sub
Sub TeilErgebnis(Farbe As Long)
'Teilergebnis-Summenformeln bei Farbe einfügen
With ws
ZeileEnde = ZeileLetzte
For lZeile = ZeileLetzte To Zeile_1 Step -1
With .Cells(lZeile, lSpalteFormel)
If .Interior.ColorIndex = Farbe Then
ZeileStart = lZeile + 1
.Formula = "=SUBTOTAL(9,R[1]C[0]:R[" & ZeileEnde - ZeileStart + 1 & "]C[0])"
'Nächste Zelle der Ebene 6 finden
Do Until ws.Cells(lZeile, lSpalteFormel).Interior.ColorIndex = Farbe_6 _
Or ws.Cells(lZeile, lSpalteFormel).Interior.ColorIndex = xlColorIndexNone
lZeile = lZeile - 1
If lZeile
Lösung 2 generiert Summenformeln mit den Summenzellen der nächsten Unterebene als Parameter.
Option Explicit
'Variablendeklaration
Private ws As Worksheet, lZeile As Long
Private ZeileEnde As Long, ZeileStart As Long, ZeileLetzte As Long
Private Const lSpalteText As Long = 1
Private Const lSpalteFormel As Long = 2
Private Const Zeile_1 As Long = 5 '1. Zeile mit Werten
'Colorindex der zu vergleichenden Farben
Private Const Farbe_1 As Long = 45 'Farbe der obersten Ebene, Ebene 1
Private Const Farbe_2 As Long = 44 'Farbe Ebene 2
Private Const Farbe_3 As Long = 40 'Farbe Ebene 3
Private Const Farbe_4 As Long = 6 'Farbe Ebene 4
Private Const Farbe_5 As Long = 36 'Farbe Ebene 5
Private Const Farbe_6 As Long = 0 'Farbe der untersten Ebene oder ohne Füllfarbe, Ebene 6
Sub SummenformelnEinfuegen()
'Fügt auf Basis der Zellfarben Summenformeln ein
Set ws = ActiveSheet
With ws
ZeileLetzte = .Cells(.Rows.Count, lSpalteText).End(xlUp).Row
End With
'Summenformeln Ebene 5 einfügen
Call Summenformel(Farbe1:=Farbe_5, Farbe2:=Farbe_6, Farbe3:=xlColorIndexNone)
'Summenformeln Ebene 4 einfügen
Call Summenformel(Farbe1:=Farbe_4, Farbe2:=Farbe_5)
'Summenformeln Ebene 3 einfügen
Call Summenformel(Farbe1:=Farbe_3, Farbe2:=Farbe_4)
'Summenformeln Ebene 2 einfügen
Call Summenformel(Farbe1:=Farbe_2, Farbe2:=Farbe_3)
'Summenformeln Ebene 1 einfügen
Call TeilErgebnis1(Farbe1:=Farbe_1, Farbe2:=Farbe_2)
End Sub
Sub Summenformel(Farbe1 As Long, Farbe2 As Long, Optional Farbe3 As Long = -1)
'Summenformeln bei Zellen mit Farbe1 einfügen
Dim strFormel As String
If Farbe3 = -1 Then Farbe3 = Farbe2
With ws
ZeileEnde = ZeileLetzte
strFormel = ""
For lZeile = ZeileLetzte To Zeile_1 Step -1
With .Cells(lZeile, lSpalteFormel)
If .Interior.ColorIndex = Farbe2 Or .Interior.ColorIndex = Farbe3 Then
If strFormel = "" Then
strFormel = "=SUM(" & .Address(ReferenceStyle:=xlR1C1)
Else
strFormel = strFormel & ", " & .Address(ReferenceStyle:=xlR1C1)
End If
ElseIf .Interior.ColorIndex = Farbe1 Then
strFormel = strFormel & ")"
.Formula = strFormel
strFormel = ""
End If
End With
Next
End With
End Sub
