funktioniert fast perfekt
04.02.2013 20:12:23
Johannes
Hallo Franz,
dein Makro hat mir sehr geholfen. Ich habe es noch so umgebaut, dass nicht nach einem Suchbegriff gesucht wird, sondern immer wenn sich in einer Spalte ein Wert ändert (gilt als Beginn für einen neuen Block) ggfl. der Seitenumbruch angepasst wird. Weiters war noch das Problem wenn ein Block länger als eine Seite war, dann ist das Makro in eine Endlosschleife gelaufen und stoppte erst am Tabellenende mit Fehler.
Nochmal danke für deine Hilfe!
Gruß Johannes
Sub Seitenwechsel_2() 'SpalteSuch As Integer)
Dim objPageBreak As HPageBreak, intI As Integer, Zeile As Long
Dim ZeileMerker1 As Long, bolMerker As Boolean, lngView As Long
Dim rngZeile As Range
Dim wks As Worksheet
'Const Suchbegriff As String = "x" 'Text zur Kennzeichnung eines Blocks der nicht durch _
Seitenwechsel getrennt werden soll
Const SpalteSuch As Long = 14 'Spalte mit Kennzeichnung , 1 = A 'ggfl. oben ausschalten
Set wks = ActiveSheet
intI = 1
bolMerker = False
Zeile = 2 'in Zeile 1 kann nicht gestartet werden da immer mit der Vorgängerzeile verglichen _
wird die es erst ab Zeile 2 gibt
ZeileMerker1 = 0
With wks
.ResetAllPageBreaks
lngView = ActiveWindow.View
If lngView xlPageBreakPreview Then ActiveWindow.View = xlPageBreakPreview
Do Until intI > .HPageBreaks.Count
Set objPageBreak = wks.HPageBreaks(intI)
Do
Zeile = Zeile + 1
' If bolMerker = False And LCase(.Cells(Zeile, SpalteSuch).Text) = LCase(Suchbegriff) _
Then 'Originalzeile mit Suchbegriff
If bolMerker = False And .Cells(Zeile, SpalteSuch) .Cells(Zeile - 1, SpalteSuch) _
Then
ZeileMerker1 = Zeile
' bolMerker = True 'Originalzeile mit Suchbegriff
' ElseIf bolMerker = True And LCase(.Cells(Zeile, SpalteSuch).Text) LCase( _
Suchbegriff) Then 'Originalzeile mit Suchbegriff
' bolMerker = False 'Originalzeile mit Suchbegriff
End If
If Zeile >= objPageBreak.Location.Row Then
GoTo Weiter01 'ausschalten falls die Info zum Testen gewünscht wird
'Test-Anfang-Anzeige Seitenumbruch Info
With objPageBreak
.Location.Range("A1").Select
MsgBox "Seitenumbruch Nr.: " & intI & vbLf _
& "Zelle: " & .Location.Address & vbLf _
& "Zeile: " & .Location.Row & vbLf _
& "Typ(-4105 = automatisch, -4135=Manuell): " & .Type
End With
'Test-Ende-Anzeige Seitenumbruch Info
Weiter01:
'ggf. manuellen Seitenumbruch oberhalb einfügen, wenn Seitenwechsel durch Block _
geht
' If bolMerker = True And ZeileMerker1 > 0 Then 'Originalzeile mit Suchbegriff
If ZeileMerker1 > 0 Then
Set rngZeile = .Rows(ZeileMerker1)
rngZeile.PageBreak = xlPageBreakManual
ZeileMerker1 = 0
End If
intI = intI + 1
.Calculate
Exit Do
End If
Loop
Loop
If lngView ActiveWindow.View Then ActiveWindow.View = lngView
End With
Set wks = Nothing: Set rngZeile = Nothing: Set objPageBreak = Nothing
End Sub