AW: leere Zeile mit Text und Formel dynamisch einfügen
28.11.2009 13:36:30
fcs
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 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