seitenumbruch steuern

liebe helfer!
Ich sitze seit Tagen an einer Aufgabe - ein Raumplan soll erstellet werden: Wann ist welcher Raum, mit welcher Veranstaltung belegt. Die Daten sollen von wechselndem, teils unqualifiziertem Personal eingetragen werden. Einmal in der Woche wird ein zweiwöchiger Zeitraum (markierter Bereich) ausgedruckt und allen Mitarbeitern ausgehändigt um sich auf dieser Basis zu besprechen.
Aufbau der Tabelle bis jetzt: in Zeile 1 stehen die Räume 1 bis 5. In Spalte1 die Tage (datum) nach unten fortlaufend.
Das Problem: Ein Tag besteht nicht aus einer Zeile, sondern aus drei: Vormittags, Nachmittags, Abends.
Meine Lösung: In der ersten Spalte nehmen je drei verbundene Zellen einen Tag auf. rechts davon stehen dann drei zeilen für die drei Tagesabschnitte pro Tag.
Für das laufende Einpflegen von Daten am Bildschirm ist diese Aufteilung gut. in der Natur der Sache liegt es aber, dass die Zelleninhalte mal groß, mal leer, mal klein sind (automatische Anpassung der Spaltenhöhe bei feststehender Spaltenbreite). Dadurch passen mal zwei Tage auf ein Blatt, mal eine ganze Woche. Das ist okay. Was aber nicht passieren soll, dass ein Tag (bestehen aus drei zeilen) durch einen Seitenumbruch zerrissen wird. Ich glaubte das durch die verbundene Zelle verhindern zu können, doch die wird gnadenlos zerteilt.
Hatte schon einige Forumsbeiträge zu dieser Problematik gefunden. Als Antwort gab es immer nur die Geißelung der ach so bösen Verbunden Zellen. Die Lösungsvorschläge waren meist zu kompliziert und soweit ich das überblicken konnte, wurde das eigentliche Problem nicht verstanden. Bestimmte zeilen sollen einfach nicht durch einen Umbruch auf zwei Seiten verteilt werden.
Bin auch für lösungen ohne verbunden zellen offen, wenn dann in der ersten spalte nur in jeder dritten zeile das fortlaufende Datum erscheint und leicht durch "Ziehen nach unten" fortgeführt werden kann.
Vielen Dank fürs aufmerksame Lesen und drüber Grübeln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub CorrectHPBreak() Dim hpB As HPageBreak Dim ws As Worksheet Set ws = ActiveSheet For Each hpB In ws.HPageBreaks If hpB.Location.Address hpB.Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=hpB.Location.MergeArea.Cells(1, 1) End If Next End Sub

Option Explicit Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim hpB As HPageBreak Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets For Each hpB In ws.HPageBreaks If hpB.Location.Address hpB.Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=hpB.Location.MergeArea.Cells(1, 1) End If Next Next ws End Sub

Option Explicit Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim hpB As HPageBreak Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.ResetAllPageBreaks For Each hpB In ws.HPageBreaks If hpB.Location.Address hpB.Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=hpB.Location.MergeArea.Cells(1, 1) End If Next Next ws End Sub

Option Explicit Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim ws As Worksheet Dim iHPCnt As Integer For Each ws In ThisWorkbook.Worksheets ' reset all page breaks ws.ResetAllPageBreaks ' correct all automatic breaks if broken within merged area in up-direction For iHPCnt = 1 To ws.HPageBreaks.Count With ws.HPageBreaks(iHPCnt) If .Type = xlPageBreakAutomatic Then If .Location.Address .Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1) .Location = .Location.MergeArea.Cells(1, 1) End If End If End With Next iHPCnt ' Correct the last HPagebreak, only if necessary If iHPCnt > 1 Then With ws.HPageBreaks(iHPCnt) If .Type = xlPageBreakAutomatic Then If .Location.Address .Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1) .Location = .Location.MergeArea.Cells(1, 1) End If End If End With End If Next ws End Sub

Hallo Thomas,
Ich hab jetzt an die 100 Versuche mit verschiedenen Konfigurationen gemacht.
Dabei habe ich auch den Index-Fehler rekonstruieren können.
Ich bin nun zu folgendem Resultat gelangt.
1. Der Code in DieserArbeitsmappe soll gelöscht werden.
2. Der folgende Code kommt in ein allgemeines Modul (im VBE Explorer Rechtsklick auf VBAProject - Einfügen - Modul)
3. Er muss manuelle über Makros oder einen Button ausgelöst werden.
4. Er stellt nur die Pagebreaks für das gerade aktive Blatt richtig.
5. Er kann nicht für (individuelle) Druckbereiche eingesetzt werden! Bei solchen müssen die Seitenumbrüche manuell durch den Benutzer gesetzt werden!

Sub CorrectPageBreaks()
Dim ws As Worksheet
Dim iHPCnt As Integer
Set ws = ActiveSheet
If ws.PageSetup.PrintArea = "" Then
ws.Cells(1, 1).SpecialCells(xlLastCell).Select
' reset all page breaks
ws.ResetAllPageBreaks
' correct all automatic breaks if broken within merged area in up-direction
For iHPCnt = 1 To ws.HPageBreaks.Count
With ws.HPageBreaks(iHPCnt)
If .Type = xlPageBreakAutomatic Then
If .Location.Address  .Location.MergeArea.Cells(1, 1).Address Then
ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1)
End If
End If
End With
Next iHPCnt    ' Correct the last HPagebreak, only if necessary
If iHPCnt > 1 Then
With ws.HPageBreaks(iHPCnt)
If .Type = xlPageBreakAutomatic Then
If .Location.Address  .Location.MergeArea.Cells(1, 1).Address Then
ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1)
End If
End If
End With
End If
Else
MsgBox "Bei Druckbereichen müssen Sie" & vbCrLf & _
"die Seitenumbrüche manuell setzen!", vbExclamation, "Druckbereich"
End If
End Sub

Bei meinen Versuchen, habe ich den Indexfehler nicht mehr produzieren können. Anscheinend verhindert das Selektieren der letzten Zelle im Blatt, dass Excel mit den Umbruch-Zählern durcheinander kommt.
Ein vollständig automatisierte Lösung wäre vielleicht möglich aber extrem aufwändig zu realisieren.
Gruess Hansueli

Sub Schaltfläche1_BeiKlick() ' Schaltfläche1_BeiKlick Makro ' passt zeilenhöhe an ActiveSheet.Unprotect Columns("B:N").Select Range("N1").Activate Selection.Rows.AutoFit Range("N2:N4").Select ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True, AllowInsertingHyperlinks:=True End Sub

Sub Schaltfläche1_BeiKlick() Dim ws As Worksheet Dim iHPCnt As Integer Set ws = ActiveSheet ws.Unprotect ws.UsedRange.Rows.AutoFit If ws.PageSetup.PrintArea = "" Then ws.Cells(1, 1).SpecialCells(xlLastCell).Select ' reset all page breaks ws.ResetAllPageBreaks ' correct all automatic breaks if broken within merged area in up-direction For iHPCnt = 1 To ws.HPageBreaks.Count With ws.HPageBreaks(iHPCnt) If .Type = xlPageBreakAutomatic Then If .Location.Address .Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1) End If End If End With Next iHPCnt ' Correct the last 2 HPagebreaks, only if necessary For iHPCnt = ws.HPageBreaks.Count - 2 To ws.HPageBreaks.Count With ws.HPageBreaks(iHPCnt) If .Type = xlPageBreakAutomatic Then If .Location.Address .Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1) End If End If End With Next iHPCnt Else MsgBox "Bei Druckbereichen müssen Sie" & vbCrLf & _ "die Seitenumbrüche manuell setzen!", vbExclamation, "Druckbereich" End If ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True, AllowInsertingHyperlinks:=True End Sub

Sub Schaltfläche1_BeiKlick() Dim ws As Worksheet Dim iHPCnt As Integer Dim bMoved As Boolean ' Execute only for Active Worksheet Set ws = ActiveSheet If ActiveSheet.Type xlWorksheet Then Exit Sub ' Unprotect ws.Unprotect ' Fit rows to content ws.UsedRange.Rows.AutoFit ' do only for entire sheet not for printareas If ws.PageSetup.PrintArea = "" Then ws.Cells(1, 1).SpecialCells(xlLastCell).Select ' reset all page breaks ws.ResetAllPageBreaks ' Loop until all Pagebreaks are at Mergedcell-boundries Do bMoved = False ' Do for all horizontal pagebreaks For iHPCnt = 1 To ws.HPageBreaks.Count With ws.HPageBreaks(iHPCnt) If .Type = xlPageBreakAutomatic Then ' if broken within merged area move pagebreak up to boundry If .Location.Address .Location.MergeArea.Cells(1, 1).Address Then ws.HPageBreaks.Add Before:=.Location.MergeArea.Cells(1, 1) bMoved = True End If End If End With Next iHPCnt Loop While bMoved Else MsgBox "Bei Druckbereichen müssen Sie" & vbCrLf & _ "die Seitenumbrüche manuell setzen!", vbExclamation, "Druckbereich" End If ' protect sheet again ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowFormattingCells:=True, AllowInsertingHyperlinks:=True End Sub

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread