Druckbereich: leere Seite
28.02.2008 21:54:00
Fred
per Makro kopiere ich ein paar Tabellen in ein neues Sheet für welches ich dann automatisch den Druckbereich einstelle. Das klappt alles wunderbar. Leider fügt mir das Programm aber irgendwie eine letzte leere Seite an... ich weiß nicht woran das liegen könnte? Selbst wenn ich nur eine Tabelle drucke, die locker auf eine Seite passt, erhalte ich eine 2. leere Seite. Was mache ich falsch?
Public Sub druckbericht()
Dim i As Integer
Dim druckbereich, drucksheets
Dim anzdb As Integer
Dim letztezeile As Integer
Dim wsnames As Variant
Application.ScreenUpdating = False
' HIER WIRD FESTGELEGT, WO SICH ZU KOPIERENDE TABELLEN BEFINDEN
drucksheets = Array("GuV", "GuV", "Bilanz", "Bilanz", "KFR", "KFR") '
druckrange = Array("B10:M45", "B47:M60", "B10:M72", "B47:M60", "B10:M54", "B47:M60")
anzdb = Application.CountA(druckrange) ' Anzahl der verschiedenen Druckbereiche
' Erstelle temporäres Sheet [Sheets("tempdrucken")]
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempdrucken").Delete
Worksheets.Add
ActiveSheet.Name = "tempdrucken"
Application.DisplayAlerts = True
' Kopiere gewünschten Tabellen in temporäres Sheet
letztezeile = 0 ' Initialisierung der Variablen
Sheets("tempdrucken").Activate
ActiveSheet.PageSetup.PrintArea = ""
For i = 1 To anzdb
If Berichte_drucken.Controls("Checkbox" & i).Value = True Then
Sheets(drucksheets(i - 1)).Range(druckrange(i - 1)).Copy
With ActiveSheet.Cells(letztezeile + 2, 2)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
letztezeile = ActiveSheet.UsedRange.Rows.Count + 5
Cells(letztezeile, 14).PageBreak = xlPageBreakManual ' Setze PageBreak
End If
Next i
' Kopiere "Title Rows" in Tabelle
Sheets("GuV").Rows("1:9").Copy
Sheets("tempdrucken").Rows("1:1").Select
Selection.Insert Shift:=xlDown
Rows("9:9").Select
Selection.Insert Shift:=xlDown
' Formatiere Spalten-Breite wie in Originaltabellen (GuV, Bilanz, KFR)
Sheets("tempdrucken").Activate
Columns(1).ColumnWidth = 0.5
Columns(2).ColumnWidth = 0.5
Columns(3).ColumnWidth = 35
Columns(4).ColumnWidth = 5
Columns(5).ColumnWidth = 5
For i = 6 To 13
Columns(i).ColumnWidth = 11
Next i
With Worksheets("tempdrucken").PageSetup
.Orientation = xlPortrait 'xllandscape
.PaperSize = xlPaperA4
.Zoom = 55
.PrintErrors = xlPrintErrorsDisplayed
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.PrintTitleRows = ActiveSheet.Rows("1:9").Address
End With
Application.Dialogs(xlDialogPrintPreview).Show
Application.DisplayAlerts = False
On Error Resume Next
Sheets("tempdrucken").Delete
End Sub
Für eure Hilfe wäre ich dankbar!!! Vielen Dank im Voraus!
Gruß
Fred