Makro bezügl. Aufsummieren meherer zellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub total() vonZeile = 3 'Startzeile bisZeile = Cells(65536, 1).End(xlUp).Row 'EndZeile Dim TotalSummen(7) Dim GesamtSummen(7) For i = vonZeile To bisZeile + 1 If Cells(i, 1) = "" Then 'neuer Block hier Zwischensumme setzen 'totalsummen ausgeben Cells(i, 1) = "*Total" For y = 1 To 7 Cells(i, y + 1) = TotalSummen(y) 'TotalSummen aufaddieren GesamtSummen(y) = GesamtSummen(y) + TotalSummen(y) 'TotalSummen wieder auf 0 TotalSummen(y) = 0 Next y End If For y = 1 To 7 TotalSummen(y) = Cells(i, y + 1) Next y Next i 'GesamtSummen ausgeben Cells(bisZeile + 2, 1) = "*Gesamt" For y = 1 To 7 Cells(bisZeile + 2, y + 1) = GesamtSummen(y) Next y End Sub

Sub total() vonZeile = 3 'Startzeile bisZeile = Cells(65536, 1).End(xlUp).Row 'EndZeile Dim TotalSummen(7) Dim GesamtSummen(7) For i = vonZeile To bisZeile If Cells(i, 1) = "" Then 'neuer Block hier Zwischensumme setzen 'totalsummen ausgeben Cells(i, 1) = "*Total" For y = 1 To 7 Cells(i, y + 1) = TotalSummen(y) 'TotalSummen wieder auf 0 TotalSummen(y) = 0 Next y End If 'Zeilen addieren For y = 1 To 7 TotalSummen(y) = TotalSummen(y) + Cells(i, y + 1) GesamtSummen(y) = GesamtSummen(y) + Cells(i, y + 1) Next y Next i 'letzte TotalSummen ausgeben Cells(bisZeile + 1, 1) = "*Total" For y = 1 To 7 Cells(bisZeile + 1, y + 1) = TotalSummen(y) Next y 'GesamtSummen ausgeben Cells(bisZeile + 2, 1) = "*Gesamt" For y = 1 To 7 Cells(bisZeile + 2, y + 1) = GesamtSummen(y) Next y End Sub

Hallo Ede!
Dein Script klappt soweit super!
Nur ein pro blem hab ich noch.
Da ich meine Daten importiere ist jeweils die jeweilige Block-Total-Line und die Gesamt-Total-Line schon vorgegeben (und da stehen auch schon Inhalte in den Zellen, nur eben nicht die richtigen :()
Die Block-Total-Lines heißen auch nicht "* Total", sondern jeweils anders, z.B. "* Gesamtzahl Autos", "* Gesamtzahl Personen", "* Nzahl an grundstücken"...
Die Gesamt-Total Line heißt wie folgt: "** Total"
Kannst du dein Script so modifizieren, dass es den Block nur soweit aufsummiert, bis eine Zeile kommt, die mit "*" (also ein Block-Total-Line) beginnt und dann dort in dieser zeile die ergebnisse reinschribst (also die bestehen ergebnisse überschreibst). Danach kommt dann immer eine leerzeile, bevor der nächste block beginnt...
Und könntest du dann ganz am ende die Grand-Total-Line ebenfalls überscrheiben lassen mit den Summen der Block-Total-Lines. Die Grand-Total Line erkennt man daran, dass sie mit "**" beginnt, also z.B. "** Total".
Das wäre echt super, denn dann funktionniert alles perfekt!! :) Achso ja, kannst du es so machen, dass man nachher in den jeweiligen Totallines nicht nur das ergebnis der aufsummierung sieht, sondern bei doppelklick die formel? :)
Hoffe das geht! Aber trotzdem schonmal vielen Dank für dein bemühen!!!!!!!!!!!!!!!!!!!!!!!
Danke, Max

Sub total() vonZeile = 3 'Startzeile bisZeile = Cells(65536, 1).End(xlUp).Row 'EndZeile Dim TotalSummen(7) Dim GesamtSummen(7) For i = vonZeile To bisZeile If Cells(i, 1) <> "" Then 'keine LEERZEILEN If Left(Cells(i, 1), 2) <> "**" Then 'DIES IST DIE SUMMENZEILE If Left(Cells(i, 1), 1) = "*" Then 'neuer Block hier Zwischensumme setzen 'totalsummen ausgeben 'Cells(i, 1) = "*Total" For y = 1 To 7 Cells(i, y + 1) = TotalSummen(y) 'TotalSummen wieder auf 0 TotalSummen(y) = 0 Next y Else 'Zeilen addieren For y = 1 To 7 TotalSummen(y) = TotalSummen(y) + Cells(i, y + 1) GesamtSummen(y) = GesamtSummen(y) + Cells(i, y + 1) Next y End If Else 'GesamtSummen ausgeben For y = 1 To 7 Cells(i, y + 1) = GesamtSummen(y) Next y End If ' "**" End If 'LeerZeile Next i End Sub

hallo nochmal,
hier eine version mit formeln für zwischensummen (*)


Sub total()
Application.Volatile
vonZeile = 3    'Startzeile
bisZeile = Cells(65536, 1).End(xlUp).Row   'EndZeile
Dim TotalSummen(7)
Dim GesamtSummen(7)
xxgesamt1 = "=sum("
For i = vonZeile To bisZeile
If Cells(i, 1) <> "" Then 'keine LEERZEILEN
If Left(Cells(i, 1), 2) <> "**" Then  'DIES IST DIE SUMMENZEILE
If Left(Cells(i, 1), 1) = "*" Then
'neuer Block hier Zwischensumme setzen
'totalsummen ausgeben
For y = 1 To 7
' hier die Zwischensumme als  Werte ausgeben
'Cells(i, y + 1) = TotalSummen(y)
' TotalSummen wieder auf 0
TotalSummen(y) = 0
Next y
'hier als Formeln setzen
Cells(i, 2).Formula = "=Sum(B" & i - xxDelta & ":B" & i - 1 & ")"
Cells(i, 3).Formula = "=Sum(C" & i - xxDelta & ":C" & i - 1 & ")"
Cells(i, 4).Formula = "=Sum(D" & i - xxDelta & ":D" & i - 1 & ")"
Cells(i, 5).Formula = "=Sum(E" & i - xxDelta & ":E" & i - 1 & ")"
Cells(i, 6).Formula = "=Sum(F" & i - xxDelta & ":F" & i - 1 & ")"
Cells(i, 7).Formula = "=Sum(G" & i - xxDelta & ":G" & i - 1 & ")"
Cells(i, 8).Formula = "=Sum(H" & i - xxDelta & ":H" & i - 1 & ")"
xxDelta = 0
'Formel für gesamt bauen
xxgesamt1 = xxgesamt1 & "B" & i & ";"
Else
'Zeilen addieren
xxDelta = xxDelta + 1
For y = 1 To 7
TotalSummen(y) = TotalSummen(y) + Cells(i, y + 1)
GesamtSummen(y) = GesamtSummen(y) + Cells(i, y + 1)
Next y
End If
Else
'GesamtSummen ausgeben
For y = 1 To 7
Cells(i, y + 1) = GesamtSummen(y)
Next y
' Gesamtsummen als Formel
xxgesamt1 = Mid(xxgesamt1, 1, Len(xxgesamt1) - 1) & ")"
'MsgBox xxgesamt1
'Cells(i, 2).Formula = xxgesamt1   ' birngt fehler 400!!!!!!!!!
End If ' "**"
End If 'LeerZeile
Next i
End Sub

gruss und viel erfolg
ede

Beliebteste Forumthreads (12 Monate)

Makro bezügl. Aufsummieren meherer zellen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread