Tabellenblätter dynamisch drucken
03.10.2007 11:21:14
Roland
Dank der gütigen Mithilfe von fcs Franz kann ich nun, mit untenstehendem Code eine gefilterte Ansicht über 12 Tabellenblätter auf ein Temporäres Tabellenblatt kopieren und ausdrucken.
Den Seitenumbruch der Einzelnen Monate wird abgefangen und auf das nächste Blatt gedruckt.
Wie kann ich nun verhindern, dass der Monatstitel, den ich jeweils vor das "Monatsbild" einfüge, nicht alleine zuunterst auf der Seite stehen bleibt sondern mit dem "Monatsbild" zuoberst auf der nächsten Seite erscheint.
Ich denke mit einer If abfrage, die sicherstellt, dass immer ein "Monatsbild" am Ende einer Seite steht, müsste das funktionieren. Nur kriege ich diesen Code nicht hin!
Besten Dank für eure Hilfe
Gruss Roland
Sub DruckenJahresuebersicht()
Dim Bereich As Range, Bild As Shape, wks As Worksheet, NextZelle, NextTitel As Range
Dim strBereich As String
Dim i As Integer, Zeile As Long
With Worksheets("Januar")
.Activate
Set Bereich = .Range("A1:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row)
'Anzahl gefilterte Mitarbeiter zählen
.Unprotect myPwd
i = Intersect(Bereich.SpecialCells(xlVisible), _
Bereich.Columns(1)).Count - 1
.Protect myPwd
End With
'Anzahl Mitarbeiter überprüfen
If i > 18 Then
MsgBox "Es sind zuviele Mitarbeiter Ausgewählt! Bitte Filter setzen!", _
vbInformation, "Druckmenü """
Exit Sub
End If
' Temporäres Tabellenblatt erstellen
Application.ScreenUpdating = False
Worksheets.Add Before:=Worksheets(1)
Set wks = Worksheets(1)
On Error GoTo weiter
With wks
'Januar Kopieren
With Worksheets("Januar")
strBereich = .Range("A1:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
.Paste Destination:=.Range("A1")
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 1, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 2, 1)
'Februar Kopieren
With Worksheets("Februar")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Februar"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'März Kopieren
With Worksheets("März")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "März"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'April Kopieren
With Worksheets("April")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "April"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'Mai Kopieren
With Worksheets("Mai")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Mai"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'Juni Kopieren
With Worksheets("Juni")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Juni"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'Juli Kopieren
With Worksheets("Juli")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Juli"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'August Kopieren
With Worksheets("August")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "August"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'September Kopieren
With Worksheets("September")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "September"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'Oktober Kopieren
With Worksheets("Oktober")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Oktober"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'November Kopieren
With Worksheets("November")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "November"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
Set Bild = .Shapes(.Shapes.Count)
Set NextTitel = .Cells(Bild.BottomRightCell.Row + 2, 1)
Set NextZelle = .Cells(Bild.BottomRightCell.Row + 3, 1)
'Dezember Kopieren
With Worksheets("Dezember")
strBereich = .Range("A3:BO" & .Cells(.Rows.Count, 3).End(xlUp).Row).Address
.Range(strBereich).CopyPicture Appearance:=xlPrinter
End With
With NextTitel
.Value = "Dezember"
.Font.Size = 16
.Font.Name = "Arial Narrow"
.Font.ColorIndex = 11
End With
.Paste Destination:=NextZelle
weiter:
On Error GoTo 0
'Ausdrucken
With .PageSetup
.RightFooter = "Seite &P von &N"
.LeftMargin = Application.InchesToPoints(0.31496062992126)
.RightMargin = Application.InchesToPoints(0.31496062992126)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.Orientation = xlPortrait
.Zoom = 70
End With
'Seitenwechsel prüfen und ggf. manuelle Wechsel einfügen
For i = 1 To .Shapes.Count
Set Bild = .Shapes(i)
Set NextZelle = Bild.TopLeftCell
For Zeile = NextZelle.Row + 1 To Bild.BottomRightCell.Row
If .Rows(Zeile).PageBreak = xlPageBreakAutomatic Then
NextZelle.EntireRow.PageBreak = xlPageBreakManual
Exit For
End If
Next
Next
'.PrintOut
Application.Dialogs(xlDialogPrint).Show
'Temporäres Tabellenblatt wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Set wks = Nothing: Set Bild = Nothing: Set NextZelle = Nothing
Set Bereich = Nothing: Set NextTitel = Nothing
Menüleiste.AktuellerMonat
Application.ScreenUpdating = True
End Sub
Anzeige