AW: habe was gefunden aber
13.03.2009 13:11:42
fcs
Hallo walli,
hier jetzt mal eine Anpassung, auf Wunsch (MsgBox) den Seitenwechsel prüft und ggf. anpasst.
Im Moment wird die Seitenvorschau angezeigt. Das muss du dann anpassen wenn alles korrekt klappt.
Das Makro ist relativ langsam, wie fast immer, wenn man per VBA an den Seitenwechseln Prüfungen/Änderungen vornimmt. Excel muss dann immer relativ viel neu berechnen.
Gruß
Franz
Private Sub CommandButton8_Click()
Dim s, bolPruefen As Boolean
Dim Z As Long
If MsgBox("Seitenwechsel prüfen?", vbYesNo, "Druckvorbereiten") = vbYes Then
bolPruefen = True
End If
Application.ScreenUpdating = False
Z = Range("A2").End(xlDown).Row
ActiveSheet.Range(Cells(2, 1), Cells(Z, 30)).Select
With ActiveSheet.PageSetup
.PrintArea = Range(Cells(2, 1), Cells(Z, 30)).Address
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
.RightHeader = "&""Arial,Fett"" "
.LeftFooter = "&""Arial,Fett""&8&P von &N"
.CenterFooter = " "
.RightFooter = "&""Arial,Fett""&8 &F &D &T"
.LeftMargin = Application.InchesToPoints(0.01)
' .RightMargin = Application.InchesToPoints(0.01)
' .TopMargin = Application.InchesToPoints(0.4)
' .BottomMargin = Application.InchesToPoints(0.3)
' .HeaderMargin = Application.InchesToPoints(0.01)
' .FooterMargin = Application.InchesToPoints(0.01)
''' .Orientation = xlPortrait ' für Hochformat
' .Zoom = 63
.Orientation = xlLandscape ' für Querformat
' .Zoom = False 'Anpassen
'---------------- damit wird auf Anpassen gestellt -----------
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
If bolPruefen = True Then
Call Seitenwechsel(ZeileLetzte:=Z, AnzahlZeilen:=9, ZeilenOberhalb:=2)
'oder Call Seitenwechsel(ZeileLetzte:=Z + 9, AnzahlZeilen:=9, ZeilenOberhalb:=2)
End If
Application.ScreenUpdating = True
ActiveWindow.SelectedSheets.PrintPreview
' ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub
Sub Seitenwechsel(ZeileLetzte As Long, AnzahlZeilen As Long, Optional ZeilenOberhalb As Long = _
0)
'ZeileLetzte=Letzte Zeile des Druckbereichs
'AnzahlZeilen = Anzahl Zeilen innerhalb derer am Ende kein Seitenwechsel sein darf
Dim Zeile1 As Long, Zeile2 As Long, Zeile As Long
Dim wks As Worksheet, bolSeitenwechsel As Boolean
Set wks = ActiveSheet
Zeile1 = ZeileLetzte - AnzahlZeilen + 1
Zeile2 = ZeileLetzte
Wiederholen:
'Prüfen, ob Horizontaler Seitenwechsel im Bereich. Alle im Bereich vorhandenen manuellen _
Seitenwechsel werden entfernt.
bolSeitenwechsel = False
For Zeile = Zeile1 + 1 To Zeile2
If wks.Cells(Zeile, 1).EntireRow.PageBreak = xlPageBreakManual Then
wks.Cells(Zeile, 1).EntireRow.PageBreak = xlPageBreakNone
GoTo Wiederholen
ElseIf wks.Cells(Zeile, 1).EntireRow.PageBreak = xlPageBreakAutomatic Then
bolSeitenwechsel = True
End If
Next
If bolSeitenwechsel = True Then
wks.Cells(Zeile1, 1).Offset(-ZeilenOberhalb, 0).EntireRow.PageBreak = xlPageBreakManual
End If
End Sub