VBA Seitenumbruch dynamisch erstellen, bestimmte Stellen vermeiden

[NobX]

Hallo zusammen im Forum,

aktuell versuche ich in die Ausgabefunktion als PDF Dokument den manuellen Seitenumbruch so einzubinden, dass bestimmte Bereiche dynamisch davon ausgenommen werden. D. h., wenn der Seitenumbruch genau an der Stelle eines Textfeldes oder Bildes stattfinden soll, soll er oberhalb erfolgen und das Bild oder Textfeld mit Inhalt nicht auf zwei Seiten trennen (die Zeilenanzahl in der Tabelle und Höhe verändert sich immer wieder unterschiedlich).

Dazu habe ich mit einen Code geabaut, der dies anhand von bestimmten Zahlenwerten im Bereich dieser Bilder oder Textfelder erkennen können sollte. Ich habe mir dazu in einem Falll die 6666 und im anderen Fall die 9999 ausgesucht. Die Idee dahinter ist: wenn diese Werte in der Zeile des vom Programm vorgesehenen jeweiligen Zeilenumbruchs enthalten sind, dann wird der Seitenumbruch auf eine vorherige Zeile festgelegt.

Eine Beispieldatei füge ich bei mit dem Hinweis, dass die Ausgabe als PDF hier nicht funktioniert wegen des unvollständigen Pfades,  - im Original geht das problemlos.
Hier Der Code:

Code:

Private Sub CommandButton1_Click()
Dim i As Integer
    Dim letzteZeile As Integer
    Const Bezeichnung1 = 6666
    Const Bezeichnung2 = 9999
    With ActiveSheet
        .ResetAllPageBreaks 'Alle Seitenumbrüche zurücksetzen
        letzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
        .PageSetup.PrintArea = "$A$2:$K" & letzteZeile
       
        For i = 2 To letzteZeile
            Select Case Cells(i, 1).Value
                    Case "Bezeichnung1"
                    If Cells(i, 1).Value = 6666 Then .HPageBreaks.Add Before:=Rows("60")
            End Select
           
            Select Case Cells(i, 7).Value
                    Case "Bezeichnung2"
                    If Cells(i, 7).Value = 9999 Then .HPageBreaks.Add Before:=Rows("90")

            End Select
        Next i
    End With
  
    'ab hier wird die Ausgabe als PDF Datei in das vorgegebene Verzeichnis durchgefürht, dies funktioniert auch in der Originalversion
     ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:="C:\Dieser PC\Users\Desktop\" & ActiveWorkbook.Worksheets("Tabelle1").Range("L1").Value, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
End Sub

[Kuwer]

Hallo Norbert,

lass die Anführungszeichen bei den Case-Abfragen weg.
Das daran anschließende Abfragen auf den Zellwert ist überflüssig, da es ja schon vorher geprüft wurde. Oder Du lässt die Select-Case-Abfragen ganz weg.

Zusätzlicher Hinweis:
Der Typ Integer für eine Zeilenvariable könnte je nach Anwendung auch mal zu klein werden. Nimm besser immer Long.

Gruß Uwe

[NobX]

Hallo Uwe,

schon mal herzlichen Dank für Deinen Tipp. Das Weglassen der Anführungsstriche war richtig. Die Seitenumbrüche werden jetzt immer an diesen Stellen gemacht, egal ob zuvor noch eine halbe Seite "Luft" ist oder nicht. Mein Ziel war es zu prüfen ob an den genannten Stellen mit den Werten 6666 oder 9999 ein Seitenumbruch stattfinden wird und wenn ja, dann soll er eben zuvor an der genannte Stelle erfolgen. Wenn der Seitenumbruch nicht in Bereich dieser Zellen liegt kann er ganz normal an der vom Programm vorgesehenen Stelle erfolgen. Wie kann ich also eine Prüfung einbauen, wo der reguläre Seitenumbruch stattfinden wird?

So habe ich aktuell den Code in der Original Datei umgebaut:

Code:

Private Sub CommandButton2_Click()
Dim i As Integer
    Dim letzteZeile As Integer
    Const Bezeichnung1 = 6666
    Const Bezeichnung2 = 9999
    With ActiveSheet
        .ResetAllPageBreaks 'Alle Seitenumbrüche zurücksetzen
        letzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
        .PageSetup.PrintArea = "$A$2:$K" & letzteZeile
       
        For i = 2 To letzteZeile
            Select Case Cells(i, 1).Value
                    Case Bezeichnung1
                    HPageBreaks.Add Before:=Rows(166)
            Select Case Cells(i, 7).Value
                    Case Bezeichnung2
                   HPageBreaks.Add Before:=Rows(186)
            End Select
            End Select
        Next i
    End With

  ActiveSheet.ExportAsFixedFormat _ 'usw. usw. usw.

Viele Grüße an alle Helfer und noch einen schönen Tag
Grüße
Norbert

[Kuwer]

Hallo Norbert,

Code:

Private Sub CommandButton1_Click()
    Const Bezeichnung1 = 6666
    Const Bezeichnung2 = 9999
    Dim i As Long
    With Me
        .ResetAllPageBreaks 'Alle Seitenumbrüche zurücksetzen
        For i = 1 To .HPageBreaks.Count
            If .HPageBreaks(i).Location.EntireRow.Cells(1).Value = Bezeichnung1 Then
              If .HPageBreaks(i).Type = xlPageBreakManual Then .HPageBreaks(i).Delete
              .HPageBreaks.Add .Rows(166)
            ElseIf .HPageBreaks(i).Location.EntireRow.Cells(7).Value = Bezeichnung2 Then
              If .HPageBreaks(i).Type = xlPageBreakManual Then .HPageBreaks(i).Delete
              .HPageBreaks.Add .Rows(186)
            End If
        Next i
    End With

Gruß Uwe

[NobX]

Hallo Uwe,

vielen Dank für Deine Unterstützung!
Kann es heute leider nicht mehr umsetzen, werde es morgen gleich testen und berichten. Sieht jedenfalls vom Lesen her so aus, dass es das tut, was ich nicht selbst hinbekommen habe! - Danke

Schönen Abend und Grüße
Norbert

[NobX]

Hallo Uwe,

nochmals danke für Deine Mühe und an alle anderen im Forum, die sich Gedanken zu meiner Anfrage gemacht haben. Ich habe den Code auprobiert und zuerst wollte er nicht so funktionieren wie ich mir das dachte.....dann habe ich noch eine Kleinigkeit verändert und jezt läuft er wie gewünscht! Das freut mich sehr, da ich daran schon eine ganze Weile gearbeitet habe!
So sieht es jetzt nach der kleinen Ergänzung aus:

Code:

Private Sub CommandButton2_Click()
    Const Bezeichnung1 = 6666
    Const Bezeichnung2 = 9999
    Dim i As Long
    With Me
        .ResetAllPageBreaks 'Alle Seitenumbrüche zurücksetzen
        For i = 1 To .HPageBreaks.Count
            If .HPageBreaks(i).Location.EntireRow.Cells(, 1).Value = Bezeichnung1 Then
              If .HPageBreaks(i).Type = xlPageBreakManual Then .HPageBreaks(i).Delete
              .HPageBreaks.Add .Rows(166)
            ElseIf .HPageBreaks(i).Location.EntireRow.Cells(, 7).Value = Bezeichnung2 Then
              If .HPageBreaks(i).Type = xlPageBreakManual Then .HPageBreaks(i).Delete
              .HPageBreaks.Add .Rows(186)
            End If
        Next i
    End With
    'anschließend wird die Datei als PDF Dokument ausgegeben......End Sub

Grüße und schönes WE!
Norbert