Hallo zusammen,
darf ich Euch wieder einmal um Eure werte Hilfe bitten?
Es soll im Querformat eine sich stetig veränderte Tabelle ausgedruckt werden. Die Tabelle hat 4 Zeilen als Headder und dieser soll auch auf allen Druckseiten erscheinen.
Dabei kann sich die Tabelle von der Zeilenanzahl her mal verkürzen oder es können viele Zeilen hinzukommen.
Es werden Daten über mehrere Spalten (A-O) eingetragen.
Tabelle kann auch ausgeblendete Zeilen enthalten.....also nur sichtbare Zeilen sollen ausgedruckt werden.
Die unterschiedlichen Datensätze sind durch eine Leerzeile und einer weiteren, farblich "blauen" (als Überschrift) Zeile vom vorhergehenden Datensatz getrennt.
Um jetzt einen strukturierten Ausdruck zu bekommen soll
a) die jede Druckseite optimal ausgenutzt werden aber
b) ein Datenblock soll durch den Seitenwechsel nicht zerstückelt werden.
Wie kann man das mittels vba-Code umsetzen?
Das Makro soll erkennen, ups... die Druckseite reicht für eine zusammenhängende Darstellung nicht aus, also generiere ich einen Seitenumbruch und schreibe ab da den Rest der Daten.....und das soll natürlich für alle Druckseiten gelten.
Hier mal ein Beispiel für den Aufbau der Tabelle in der Anlage.
Wäre schön, wenn Ihr mir da helfen könntet.
Hallöchen,
schaue mal, dass Du die jeweiligen "Abschnittsenden" irgendwie markierst. Ich hatte hier mal einen Ansatz, wo ich das mit "AS" gemacht habe.
Code:
Sub ZeilenUmbruchSetzen()
'Variablendeklarationen
'Integer
Dim iCnt%, iFoundRow%
'Mit dem Blatt 1
With Worksheets(1)
'Seitenumbrueche zuruecksetzen
.ResetAllPageBreaks
'Zaehler fuer Seitenumbrueche setzen
iCnt = 1
'Erste Fundstelle ermitteln
Set c = .Columns(1).Find(What:="AS", After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext)
'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)
'Zaehler hochsetzen
iCnt = iCnt + 1
'Ende Wenn die Treffezeile unter der Umbruchzeile leigt, dann
End If
'Trefferzeile merken
iFoundRow = c.Row
'naechsten Treffer suchen
Set c = .Columns(1).FindNext(c)
'Ende Schleife ueber alle Treffer
Loop While Not c Is Nothing And c.Address <> firstaddress And .HPageBreaks.Count >= iCnt
'Ende Wenn etwas gefunden wurde, dann
End If
'Mit dem Blatt 1
End With
End Sub
Hallo André,
vielen Dank für Deinen Lösungsvorschlag!
Leider ist das Ergebnis nicht wie erwartet.
Ich habe mal die Umbruchmarke in die Spalte 18 verlegt und mit Deinem Makro getestet.
Egal in welche Zeile ich die Marke handisch setze, der gewünschte Umbruch findet an einer anderen Stelle statt!
Hast Du vielleicht noch ne Idee warum das so ist?
Schön wäre natürlich, auch wenn die Umbruchmarken nicht händisch gesetzt werden müssten.
Hallöchen,
sorry, war in meinem Beitrag falsch beschrieben. mit "as" markiere ich einen Abschnittsbeginn.
Wenn man das nicht händisch setzen will könnte man z.B. nach der Farbe schauen. Allerdings muss man dann die Zellen einzeln durchgehen weil man die nicht mit "FIND" findet
Kennst Du Dich bisschen mit VBA aus ?
Im Prinzip entfällt das mit dem Find. Die Schleife könnte so etwas sein
Code:
Do While icnt <= ActiveSheet.UsedRange.Rows.Count
if cells(icnt,1).interior.color = ... Then Set c = cells(icnt,1)
'hier die Prüfung , Umbruch setzen usw
icnt=icnt+1
Loop
... wobei man die Verarbeitung auch etwas kürzer gestalten kann als im ursprünglichen code.
Hallo André,
ja ein klein wenig kenne ich mich aus.
Habe es mal so versucht (abgewandeltes Beispiel aus dem Netz).
Aber auch hier muss ich die Marken für den Umbruch händisch setzen.
Code:
Sub SeitenumbruchXXX()
Dim L As Long
Application.ScreenUpdating = False
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.ResetAllPageBreaks
iRowL = Cells(Cells.Rows.Count, 1).End(xlUp).Row
For L = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(L, 18).Value = "AS" Then
ActiveWindow.SelectedSheets.HPageBreaks.Add before:=Cells(L - 1, 18)
End If
Next
Application.ScreenUpdating = True
With ActiveSheet.PageSetup
.PrintArea = "A1:O" & iRowL
End With
ActiveSheet.PrintPreview
End Sub
Um die blauen Zeilen zu ermitteln habe ich fogendes Makro:
Code:
Sub BlaueZeilen_zaehlen()
Dim L As Long
Dim zahl As Long
Dim rowPos
zahl = 0
ActiveSheet.ResetAllPageBreaks
iRowL = Cells(Cells.Rows.Count, 1).End(xlUp).Row
For L = 6 To iRowL
If Rows(L).Hidden = False Then
If Cells(L, 15).Interior.ColorIndex = 23 Then
zahl = zahl + 1 'Blaue Zeilen zählen
rowPos = rowPos + 1 '
End If
If Cells(L, 15).Interior.ColorIndex = 23 Then
rowPos = Cells(L, 17).Value
'???????????
'???????????
'Cells(L, 18) = "PB"
End If
End If
Next
MsgBox zahl & " Zeilen im relevanten Bereich sind blaue Headder-Zeilen!"
With ActiveSheet.PageSetup
.PrintArea = Range(Cells(1, 1), Cells(iRowL, 17)).Address
End With
ActiveSheet.PrintPreview
End Sub
Ich ermittle hier die Anzahl der blauen Zeilen, die mir die Anzahl der unterschiedlichen Abschnitte liefert.
Wie ich aber jetzt per vba den automatischen Seitenumbruch generieren soll... da stehe ich gerade auf dem Schlauch.
Wie bereits gesagt sollen die Blöcke zwischen den blauen Zeilen nicht zerschnitten werden.
Vielleicht hast Du da noch eine Hilfestellung.
Hallo Erich,
das ist jetzt mal aufbauend auf dem ersten code, auch wenn der sicher noch etwas optimaler geht
. Die Zählung ist übrigens für die Seitenumbrüche und nicht die Abschnittsmarker oder -farben. Hier kommt jetzt noch ein Zeilenzähler dazu.
Code:
Sub ZeilenUmbruchSetzen_Color()
'Variablendeklarationen
'Integer
Dim iCnt%, rCnt%, iFoundRow%, c As Range, firstAddress As String
'Mit dem Blatt 1
With Worksheets(2)
'Seitenumbrueche zuruecksetzen
.ResetAllPageBreaks
'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 = 15773696 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)
'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 = 15773696 Then
Set c = Cells(rCnt, 1)
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
'Ende Wenn etwas gefunden wurde, dann
End If
'Mit dem Blatt 1
End With
End Sub
Hallo André,
vielen Dank für Deine Mühe, passt schon fast.
Leider habe ich den Code noch nicht so ganz verstanden.
Der Seitenumbruch funktioniert .... aber leider noch nicht so ganz.
Datenblöcke werden an den Seitenenden des Ausdrucks immer noch zerstückelt.
Es sollte keine "blaue" Zwischen-Headder-Zeile am Seitenende des Druckblattes stehen und die dazugehörigen weiteren Datenzeilen auf dem nächsten Blatt weitergehen.
Heißt, wird bei "jeder" Druckseite die Anzahl der zu druckenden Zeilen pro Block überschritten, sollte der überlaufende Datenblock (auf der Seite) auf der nächsten Seite gedruckt werden.
Hast Du noch eine Idee wie sich das Zerstückeln vermeiden lässt?
Vielleich beschreibe ich das auch zu umständlich.
Hallo Erich,
dann müsste ich mal die Datei sehen, ...
Hallo André,
hatte ich doch in meiner ersten Anfrage bereits angehängt...natürlich ohne Makros.
Reicht Dir Diese Datei?
... OK, schau ich mir morgen an