Block vor umbruch schuetzen!!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi,
versuch diesen Code mal. Er sollte mit Rahmen und per- Hand- Markierungen funzen.

Option Explicit
Sub BrücheSetzen()
'Ursprungs- Code:hatetepe://wewewe.herber.de/forum/messages/614856.html
'Bruch=horizontaler Zeilenumbruch

Dim hpbBruch As HPageBreak
Dim rngZelle As Range
Dim blnKeinUmbruch() As Boolean 'True: Zeile hat irghendwo einen Rahmen
                               'oder liegt unter einem markierten Bereich
Dim blnVerschoben As Boolean 'True: Es wurde ein Bruch verschoben
Dim i As Long
Dim Erbsen As Long 'Damit es keine unendliche Geschichte wird

'In Zeilenumbruch- Vorschau wechseln, um ständige Neuberechnung der
'Zeilenumbrüche zu erzwingen
ActiveWindow.View = xlPageBreakPreview
On Error GoTo Fehler
Application.ScreenUpdating = False
With ActiveSheet
  ReDim blnKeinUmbruch(1 To .UsedRange.Rows(.UsedRange.Rows.Count).Row)
'******************************
'ggf. zuerst die vorhandenen Brüche löschen
  .ResetAllPageBreaks
'******************************

'----------------------------
'Zellen mit Rahmen suchen
'Im Array blnKeinUmbruch bekommt die entsprechende Zeilennummer den Wert True

  For Each rngZelle In .UsedRange
    If rngZelle.Row > 1 And _
    (rngZelle.Borders(xlEdgeTop).LineStyle = xlContinuous Or _
    rngZelle.Borders(xlEdgeLeft).LineStyle = xlContinuous Or _
    rngZelle.Borders(xlEdgeRight).LineStyle = xlContinuous Or _
    rngZelle.Borders(xlEdgeBottom).LineStyle = xlContinuous) Then
      If rngZelle.Row > UBound(blnKeinUmbruch) Then
        ReDim Preserve blnKeinUmbruch(UBound(blnKeinUmbruch) + 1)
      End If
      blnKeinUmbruch(rngZelle.Row) = True
    End If
  Next
'----------------------------
'Alle markierten Zeilen durchlaufen
'Im Array blnKeinUmbruch bekommt die entsprechende Zeilennummer den Wert True


  For Each rngZelle In Selection.Rows
    If rngZelle.Row > UBound(blnKeinUmbruch) Then
      ReDim Preserve blnKeinUmbruch(UBound(blnKeinUmbruch) + 1)
    End If
    blnKeinUmbruch(rngZelle.Row) = True
  Next


'----------------------------
'Alle Brüche prüfen, ob sie verschoben werden müssen
'Wenn ja:   neuen Bruch über dem verbotenen Bereich einfügen
'           alten Bruch löschen
'           Schleife abbrechen und neu starten
'           weil HPageBreaks- Collection neue Struktur hat
'           und weil automatische Brüche sich ggf. in einen
'           verbotenen Bereich geschoben haben
'Schleife wird so oft durchlaufen, bis keine Verschiebungen
'mehr getätigt wurden --> bis kein Bruch mehr in einem verbotenen Bereich liegt
  Do
  Erbsen = Erbsen + 1
  blnVerschoben = False
  For Each hpbBruch In .HPageBreaks
    If blnKeinUmbruch(hpbBruch.Location.Row) Then
      'Bruch muß da weg
      For i = hpbBruch.Location.Row To 1 Step -1
        'nächsthöhere freie Zelle suchen
        If Not blnKeinUmbruch(i) Then Exit For
      Next i

      'Bruch löschen, wenn manueller Bruch
      'und neuen Bruch einfügen
      If hpbBruch.Type = xlPageBreakManual Then hpbBruch.Delete
      .HPageBreaks.Add .Cells(i, 1): DoEvents
      blnVerschoben = True
      Exit For 'hpbbruch, weil Collection durch neuen hbp andere Struktur

    End If
  Next hpbBruch
  Loop While blnVerschoben And Erbsen < 42
End With
Application.ScreenUpdating = True
If Not Erbsen = 42 Then
  MsgBox "Fertig.", vbInformation + vbOKOnly, "(c) MichaV"
Else
  MsgBox "Abgebrochen, geschützter Bereich ist größer als eine Seite.", vbCritical + vbOKOnly, "(c) MichaV"
End If
End
Fehler:
Application.ScreenUpdating = True
MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description, vbOKOnly + vbCritical, "Ooops"
End Sub
Gruss- Micha
PS: Rückmeldung wäre nett

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread