Druckbereich: Umbrüche dürfen nicht zerteilen

Hallo,
ich habe folgendes Problem beim Thema Druckbereich und Seitenumbrüche:
Ich möchte ein Raumbuch erstellen. Ein Eintrag im Raumbuch besteht immer aus x-Zeilen. Die Zeilenhöhe dieser Zeilen kann aber Variable sein, sodass je nach Zeilenhöhe zwei, drei oder vier Raumbucheinträge auf eine Seite passen. Mir ist es nun ein Anliegen, dass diese Einträge durch Seitenumbrüche nicht geteilt werden.
Meine bisherige Lösung: Einfach nur 2 Einträge pro Seite. Umbrüche werden über Marko gesetzt mit einer einfachen Schleife.
Ziel: Seiten mit Einträgen möglichst gut zu füllen ohne die Einträge zu zerteilen.
Zur Veranschaulichung die Tabelle aus meiner Arbeitsmappe.
https://www.herber.de/bbs/user/113540.xlsx
Danke :)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Seitenumbruch() Dim LR As Double, LastKrit As Double, LastPB As Double, i As Double Application.ScreenUpdating = False With ActiveSheet .ResetAllPageBreaks LR = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1 i = 5 Do Until i >= LR If .Cells(i, 1).MergeCells Then ' Verbundene Zelle = Kriterium für möglichen PB LastKrit = i End If If .Rows(i).PageBreak = xlPageBreakAutomatic Then LastPB = i End If If LastKrit < LastPB Then .HPageBreaks.Add Before:=Rows(LastKrit) LastPB = LastKrit i = LastKrit End If i = i + 1 Loop End With End Sub

Hallo nochmal
im Debugmodus hat alles geklappt..
Die Ermittlung für den nächsten automatischen Umbruch kommt scheinbar nicht so schnell mit.
Deshalb hab ich Screenupdating drin gelassen und noch einmal neu berechnet.

Sub Seitenumbruch()
    Dim LR As Double, LastKrit As Double, LastPB As Double, i As Double
    With ActiveSheet
        .ResetAllPageBreaks
        LR = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1
        i = 5
        Do Until i >= LR
            If .Cells(i, 1).MergeCells Then ' Verbundene Zelle = Kriterium für möglichen PB 
                LastKrit = i
            End If
            If .Rows(i).PageBreak = xlPageBreakAutomatic Then
                LastPB = i
            End If
            If LastKrit < LastPB Then
                .HPageBreaks.Add Before:=Rows(LastKrit)
                Application.Calculate ' sonst wird der nächste automatische PB nicht ermittelt 
                LastPB = LastKrit
                i = LastKrit
            End If
            i = i + 1
        Loop
    End With
End Sub

LG UweD

Sub Seitenumbruch() Dim LR As Double, LastKrit As Double, LastPB As Double, i As Double With ActiveSheet .ResetAllPageBreaks LR = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1 For i = 5 To LR If .Cells(i, 1).MergeCells Then ' Verbundene Zelle = Kriterium für möglichen PB LastKrit = i End If If .Rows(i).PageBreak = xlPageBreakAutomatic Then LastPB = i End If If LastKrit < LastPB Then .HPageBreaks.Add Before:=Rows(LastKrit) Application.Calculate ' sonst wird der nächste automatische PB nicht ermittelt LastPB = LastKrit i = LastKrit End If Next MsgBox "Fertig" End With End Sub

Beliebteste Forumthreads (12 Monate)

Druckbereich: Umbrüche dürfen nicht zerteilen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread