AW: SummeWenn
10.08.2005 14:09:57
IngGi
Hallo Sören,
hier nochmal das Makro mit Kommentaren. Viel Erfolg.
Sub Summen()
Dim BerKennung As Range 'Obere linke Zelle des aktuellen Bereiches
Dim FolgeBerKennung As Range 'Obere linke Zelle des nachfolgenden Bereiches
Dim BezZelle As Range 'Zelle in Spalte A, in die z.B. "AA" reingeschrieben wird
Dim SumZelle As Range 'Zelle in Spalte B, mit der zugehörigen Summe (siehe BezZelle)
Dim Zelle As Range 'Zelle in Spalte D, zum Prüfen, ob z.B. "AA" in Spalte A schon aufsummiert ist
Dim Summand As Range 'Zelle in Spalte D, zum Aufsummieren für Eintrag in Spalte B
Dim Ende As Byte 'Merker zum Beenden des Makros nach dem letzten Bereich
Dim Summe As Double 'Zwischenspeicher zum Aufsummieren der Einträge in Spalte E
'In Spalte A "Bereich 1" suchen und Zelle in Variable übergeben
Set BerKennung = Columns(1).Find(what:="Bereich 1", lookat:=xlWhole)
'In Spalte A nächste Zelle, die mit "Bereich" beginnt suchen und Zelle in Variable übergeben
Set FolgeBerKennung = Columns(1).Find(what:="Bereich", lookat:=xlPart)
Do 'Bereich für Bereich abarbeiten, bis letzter Bereich bearbeitet (Ende>1)
'Wenn beim letzten bearbeiteten Bereich in Spalte A keine weitere Zelle mit dem Eintrag "Bereich..."
'mehr gefunden wurde, kommt nun der letzte zu bearbeitende Bereich. In diesem Fall wurde beim
'letzten Schleifendurchgang die Variable Ende von 0 auf 1 erhöht und wird nun nochmal von 1 auf 2
'erhöht. Damit wird am Ende dieses Schleifendurchganges die Schleife verlassen und das Makro endet.
If Ende > 0 Then Ende = Ende + 1
'Im aktuellen Bereich (Zeile von BerKennung bis Zeile von FolgeBerKennung) in Spalte D alle Zellen prüfen...
For Each Zelle In Range(BerKennung.Offset(0, 3), FolgeBerKennung.Offset(-2, 3))
'... es wird geprüft, ob der Eintrag dieser Zelle in Spalte A bereits aufsummiert wurde. Falls nicht,
'wird dies jetzt gemacht.
If Range(BerKennung.Offset(1, 0), FolgeBerKennung.Offset(-2, 0)).Find(what:=Zelle) Is Nothing Then
'Zelle für nächste Bezeichnung in Spalte A bzw. Summe in Spalte B ermitteln
'Wenn die Zelle unterhalb BerKennung leer ist, kommt die nächste Bezeichnung dort hinein...
If BerKennung.Offset(1, 0) = "" Then
Set BezZelle = BerKennung.Offset(1, 0) 'Zelle in Variable übergeben
Else '...sonst kommt sie in die nächste freie Zelle unterhalb von BerKennung
Set BezZelle = BerKennung.End(xlDown).Offset(1, 0)
End If
'Zelle für nächste Summe (rechts neben BerZelle) ebenfalls in Variable übergeben
Set SumZelle = BezZelle.Offset(0, 1)
'Alle Einträge in Spalte E mit der passenden Bezeichnung in Spalte D (diejenige, welche in Spalte A
'als nächstes eingetragen werden soll) in der Variablen Summe aufsummieren.
For Each Summand In Range(BerKennung.Offset(0, 3), FolgeBerKennung.Offset(-2, 3))
If Summand = Zelle Then 'Wenn passender Eintrag in Spalte D...
Summe = Summe + Summand.Offset(0, 1) '...Wert in Spalte E in der Variablen Summe aufsummieren
End If
Next Summand 'und nächste Zelle
BezZelle = Zelle 'Bezeichnung aus Spalte D in Spalte A eintragen
SumZelle = Summe 'Zugehörige Summe aus der Variablen Summe in Spalte B eintragen
Summe = 0 'Variable Summe für nächste Summenbildung zurücksetzen
End If
Next Zelle 'nächste Zelle darauf prüfen, ob Eintrag in Spalte A bereits aufsummiert ist
'Jetzt ist der aktuelle Bereich fertig und die Bearbeitung des nächsten Bereiches muss vorbereitet werden.
'Die obere linke Zelle des folgenden Bereiches wird zur oberen linken Zelle des aktuellen Bereiches
Set BerKennung = FolgeBerKennung
'Die obere linke Zelle des folgenden Bereiches wird neu ermittelt
'Dazu wird zunächst in Spalte A die nächste Zelle gesucht, die mit "Bereich" beginnt
'Diese Zelle wird in die Variable FolgeBerKennung übergeben
Set FolgeBerKennung = Columns(1).Find(what:="Bereich", after:=FolgeBerKennung)
'Wurde als nächste Zelle, die mit "Bereich" beginnt die Zelle $A$1 gefunden, bedeutet dies,
'dass unterhalb des nächsten Bereiches kein weiterer Bereich mehr folgt (in diesem Fall beginnt
'die Suche wieder oben in Spalte A und es wird wieder der erste Bereich gefunden).
If FolgeBerKennung.Address = "$A$1" Then
'Wenn es keinen nachfolgenden Bereich mehr gibt, wird die Zelle FolgeBerKennung über den letzten
'Eintrag in Spalte D ermittelt und in die Variable FolgeBerKennung übergeben
Set FolgeBerKennung = Range("D65536").End(xlUp).Offset(2, -3)
'Jetzt noch den Merker für das Makroende nach Bearbeitung des nächsten Bereiches (=letzter Bereich)
'setzen.
Ende = Ende + 1
End If
Loop Until Ende > 1 'Wenn Merker gesetzt, Schleife verlassen und Makro beenden.
End Sub
Gruß Ingolf