Thema: leere Zeile mit Text und Formel dynamisch einfügen | Herbers Excel-Forum

Hallo zusammen,
ich habe folgendes Problem das ich mit meinen wenigen VBA Kenntnissen nicht lösen kann.
Ich habe eine Tabelle mit n Zeilen.
- Nach jeweils ca. 53 Zeilen sollte eine Zeile mit dem Text "Zwischentotal " (Spalte C) und in die Summen-Formel für die 53 Zeilen (Spalte H) eingefügt bzw. gerechnet werden (im Register "Beschrieb" gelb markiert). Sollte die Zeile 53 nicht leer sein, soll das Makro weitersuchen bis es eine leere Zeile gefunden hat und dann obgenanntes einfügen.
- Diese Summe soll auf die nächste Seite übertragen (Spalte H) werden mit dem Text "Übertrag" (Spalte C).
https://www.herber.de/bbs/user/66242.zip
Ich habe einige Codebausteine hinterlegt...tja ich komm nicht weiter.
Vielen Dank für eure Hilfe
Gruss Christian

Hallo Christian,
das variable Einfügen von Seitenwechseln ist schon relativ komplex. Nachfolgend eine Prozedur die in deinem Blatt Seitenwechsel und Formelzeilen einfügt. Als Funktion hab ich dabei TEILERGEBNIS verwendet. Das hat den Vorteil, das die Formel immer ab Zeile J10 summieren kann und die Zwischensummen und Überträge auf den Seiten bei der Summenberechnung ausgeklammert werden.
Das Makro ist relativ langsam und braucht in deiner Datei bei mir (Notebook, Excel2007, Windows Vista 32 Bit, Pentium dual core T4200, 2 GHz, 4 GB Arbeitsspeicher) ca. 2 Sekunden pro Seite, um am Ende 27 Seiten aufzubereiten. Neben Arrayformeln ist das Auswerten und Einfügen von Seitenwechseln in größeren Dateien mit das rechenintensivste was Excel an VBA-Funktionen zu bieten hat. Vista setzt Excel während der Makroausführung manchmal sogar in den Status "Keine Rückmeldung" :-( , was ber nicht bedeutet, dass das Makro nicht mehr ausgeführt wird - es dauert halt einfach.
Gruß
Franz

Sub Seitenwechsel()
Dim wks As Worksheet, ZeileLeer1 As Long, ZeileLeer2 As Long
Dim ZeilePosition1 As Long, ZeilePosition2 As Long
Dim Seitenwechsel As Long, StatusCalc As Long
Dim LetzteZeile As Long, Zeile As Long
Set wks = Worksheets("Beschrieb")
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlManual
.EnableEvents = False
End With
With wks
'Alle Seitenwechsel löschen
Application.StatusBar = "Seitenwechsel werden zurückgesetzt"
wks.ResetAllPageBreaks
LetzteZeile = .Cells(.Rows.Count, 3).End(xlUp).Row
'Alle vorhandenen Zwischensummen und Übertragzeilen entfernen
Application.StatusBar = "Zwischensummen und Übertragzeilen werden entfernt"
For Zeile = LetzteZeile To 2 Step -1
If .Cells(Zeile, 3).Value = "Zwischensumme" _
Or .Cells(Zeile, 3).Value = "Übertrag" Then
.Rows(Zeile).Delete shift:=xlShiftUp
End If
Next
LetzteZeile = .Cells(.Rows.Count, 3).End(xlUp).Row
Zeile = 5
ZeileLeer1 = Zeile
ZeileLeer2 = Zeile
Do Until Zeile > LetzteZeile
'Prüfen, ob Zelle in Spalte C (3) leer
If .Cells(Zeile, 3) = "" Then
ZeileLeer2 = ZeileLeer1 'vorherige leere Zeile merken
ZeileLeer1 = Zeile 'letzte leere Zeile merken
End If
'Prüfen of Position in Spalte 2 wichtig, wenn keine Leerzeilen auf Seite
If .Cells(Zeile, 2) <> "" Then
ZeilePosition2 = ZeilePosition1 'vorherige Positionszeile merken
ZeilePosition1 = Zeile 'letzte Positionszeile merken
End If
'Prüfen, ob automatischer Seitenwechsel in Zeile
If .Cells(Zeile, 1).EntireRow.PageBreak = xlPageBreakAutomatic Then
If Seitenwechsel < ZeileLeer1 Then
'Seite enthält Leerzeilen - Seitenwechsel an Leerzeile einfügen
If Zeile - ZeileLeer1 > 1 Then
Zeile = ZeileLeer1 + 1
Else
Zeile = ZeileLeer2 + 1
End If
'2 Leerzeilen einfügen
.Range(.Rows(Zeile), .Rows(Zeile + 1)).Insert shift:=xlShiftDown
Else
'keine Leerzeilen auf der Seite - Seitenwechsel an Positionsnummer einfügen
If Zeile - ZeilePosition1 > 2 Then
Zeile = ZeilePosition1
Else
Zeile = ZeilePosition2
End If
'3 Leerzeilen einfügen
.Range(.Rows(Zeile), .Rows(Zeile + 2)).Insert shift:=xlShiftDown
Zeile = Zeile + 1
End If
'Text und Formeln eintragen, Zeile fett formatieren
.Cells(Zeile, 3).Value = "Zwischensumme"
.Rows(Zeile).Font.Bold = True
.Cells(Zeile, 10).FormulaR1C1 = "=SUBTOTAL(9,R6C10:R[-1]C)"
.Cells(Zeile + 1, 3).Value = "Übertrag"
.Rows(Zeile + 1).Font.Bold = True
.Cells(Zeile + 1, 10).FormulaR1C1 = "=SUBTOTAL(9,R6C10:R[-1]C)"
.Rows(Zeile + 1).PageBreak = xlPageBreakManual
Seitenwechsel = Zeile + 1 'Position des Seitenwechsel merken
LetzteZeile = .Cells(.Rows.Count, 3).End(xlUp).Row
Application.StatusBar = "Zeile " & Zeile & " von " & LetzteZeile _
& " abgearbeitet"
End If
Zeile = Zeile + 1
Loop
End With
With Application
.StatusBar = False
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
'  MsgBox "Fertig"
End Sub

Hallo Franz,
was soll ich da noch sagen...einfach genial, ich hätte das niemals hinbekommen. Vielen herzlichen Dank!
Gruss Christian