Excel vba Variable Druckbereiche

[sharky51]

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.

[schauan]

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

[sharky51]

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!!!