Dynamischer Seitenumbruch
25.08.2014 14:47:06
Niko
ich habe eine ziemlich lange Pivottabelle für die Reports in unserem Unternehmen. Ich habe ein Makro erstellt, mit dem der Druckbereich dynamisch erstellt wird und anschließend das Sheet als PDF gespeichert sowie gedruckt wird. Nun habe ich allerdings das Problem, dass die Seitenumbrüche willkürlich gesetzt werden. Gibt es eine Möglichkeit eines dynamischen Seitenumbruchs?
Als Beispiel: Wenn die Seite voll ist, soll das Makro schauen, ob in Spalte B in der jeweiligen Zelle, wo es sonst den Seitenumbruch hinzufügt, etwas steht. Wenn ja, soll darüber der Seitenumbruch erfolgen. Wenn nein, soll der Seitenumbruch soweit noch oben verschoben werden, bis in der Zelle etwas steht.
Ich hoffe, ich konnte mein Problem halbwegs schildern. Hab dazu auch mal eine Beispieldatei erstellt: https://www.herber.de/bbs/user/92281.xlsx
Und hier mein Makro fürs Speichern, welches ich zurzeit verwende:
Sub DruckenFBS()
'Zellenberechnungen aktualisieren
ActiveSheet.Calculate
'Druckbereich definieren
Dim AnzahlEinträgeZeilen As Integer
Dim AnzahlEinträgeSpalten As Integer
'Spalten-/Zeileneinträge werden gezählt
Zeilen = WorksheetFunction.CountA(Sheets("Report FBS").Range("I1:I20000"))
Spalten = WorksheetFunction.CountA(Sheets("Report FBS").Range("A4:L4"))
With ActiveSheet.PageSetup
'Festlegung auf Hochformat
.Orientation = xlLandscape
'Druckbereich definieren
.PrintArea = Range(Cells(1, 1), Cells(Zeilen + 12, Spalten)).Address
'Seitenbreite definieren
.FitToPagesWide = 1
'Seitenhöhe definieren
.FitToPagesTall = False
'Seitenzahl bestimmen
.CenterFooter = "&8Seite &P von &N"
End With
'Als PDF an Wunschort speichern
UserForm2.Show
UserForm2.Hide
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Sheets("GrundlageReportFBS").Cells( _
19, 3) & "\" & Sheets("Report FBS").Cells(1, 1) & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties _
:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Druckmöglichkeit
Dim x As Byte
x = Application.InputBox("Wie oft soll gedruckt werden ?", "Drucken", 0, Type:=1)
If x False Then
Sheets("Report FBS").PrintOut Copies:=x
End If
'Druckbereich wieder aufheben
Dim Tabelle As Worksheet
For Each Tabelle In ActiveWorkbook.Worksheets
Tabelle.PageSetup.PrintArea = ""
Next Tabelle
'Kommentare löschen
Sheets("Report FBS").Range("N5:N11").ClearContents
Sheets("Report FBS").Range("N21:N10000").ClearContents
'Meldung über das Ende
MsgBox ("Erfolgreich ausgeführt!")
End Sub