(12.11.2020, 20:38)sharky51 schrieb: [ -> ]Hi André,
ok, ich freue mich wenn Du Dir das nochmals ansehen möchtest.
Btw. In der Durckvorschau sehe ich ja bereits, dass das Endergebnis noch nicht passt.
Hallo André,
darf ich Dich nochmals nerven mit meiner Nachfrage ob Du Dir mein Problem nochmals ansehen konntest?
Ich habe immer noch keine Lösung erarbeiten können.
Hi Erich,
hier mal noch ein Versuch ...
Code:
Sub ZeilenUmbruchSetzen_Color()
'Variablendeklarationen
'Integer
Dim iCnt%, rCnt%, iFoundRow%, c As Range, firstAddress As String
Dim lView
'Mit dem Blatt 1
With Worksheets(1)
'Seitenumbrueche zuruecksetzen
.ResetAllPageBreaks
Application.ScreenUpdating = False
lView = ActiveWindow.View
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = lView
Application.ScreenUpdating = True
'Zaehler fuer Seitenumbrueche setzen
rCnt = 1: iCnt = 1
'Erste Fundstelle ermitteln
Do While Cells(rCnt, 1).Row < ActiveSheet.UsedRange.Rows.Count
If Cells(rCnt, 1).Interior.Color = 12611584 Then
Set c = Cells(rCnt, 1)
Exit Do
End If
rCnt = rCnt + 1
Loop
'Wenn etwas gefunden wurde, dann
If Not c Is Nothing Then
'erste Fundstelle merken
firstAddress = c.Address
'Zeilennummer merken
iFoundRow = c.Row
'Schleife ueber alle Treffer
Do
'Wenn die Treffezeile unter der Umbruchzeile leigt, dann
If c.Row > .HPageBreaks(iCnt).Location.Row Then
'Seitenumbruch vor letztes WSC einfuegen
.HPageBreaks.Add before:=Cells(iFoundRow, 1)
Debug.Print iCnt & vbTab & Cells(iFoundRow, 1).Address & vbTab & c.Address
'Zaehler hochsetzen
iCnt = iCnt + 1
'Ende Wenn die Treffezeile unter der Umbruchzeile leigt, dann
End If
'Trefferzeile merken
iFoundRow = c.Row
'naechsten Treffer suchen
rCnt = rCnt + 1
Do While Cells(rCnt, 1).Row < ActiveSheet.UsedRange.Rows.Count
If Cells(rCnt, 1).Interior.Color = 12611584 Then
Set c = Cells(rCnt, 1)
Debug.Print c.Address
Exit Do
End If
rCnt = rCnt + 1
Loop
'Ende Schleife ueber alle Treffer
Loop While Not c Is Nothing And c.Address <> firstAddress And .HPageBreaks.Count >= iCnt And rCnt <= ActiveSheet.UsedRange.Rows.Count
'Ende Wenn etwas gefunden wurde, dann
End If
'Mit dem Blatt 1
End With
End Sub
Hallo André,
herzlichen Dank für die erneute Hilfe!
Bei einem ersten Test hat es nun gut funktioniert.
Will es noch bei unterschiedlichen Seitenlängen ausprobieren.
Vielen Dank nochmals!!!