AW: Seitenumbruch in VBA variable halten
31.03.2005 17:22:23
Frank
Hallo JayLen,
ich habe das für ein Projekt mal geschrieben und für Dich es zusammengestutzt. Es ist trotzdem mehr drin und soll Dir nur veranschaen, wie es gemacht werden kann. Es ist ausbaufähig, sollte Dir aber als Lösungansatz schon brauchbares liefern:
Option Explicit
Public
Sub sÜberträge()
Dim lngLastRow As Long ' letzte Zeile des Arbeitsblattes
Dim lngCurRow As Long ' aktuelle Zeile
Dim lngLastMerkRow As Long
Dim intZeilen As Integer
Dim lngErsteZeileaufSeite As Long ' Erste, in die Summe aufzunehmende, Zeile
Dim blnNewErlZ As Boolean ' Neuer Absatz beginnt mit Datum!
Dim Zelle As Range
Dim intPageCounter As Integer
lngLastMerkRow = 4
lngCurRow = 4 ' Startzeile
lngErsteZeileaufSeite = 4
blnNewErlZ = False
intPageCounter = 0
lngLastRow = Cells.SpecialCells(xlLastCell).Row
While lngCurRow <= lngLastRow
' Neue Seite ?
If Rows(lngCurRow).PageBreak = xlPageBreakAutomatic Then
intPageCounter = intPageCounter + 1
Application.StatusBar = "Überträge der Seite " & _
intPageCounter & " werden ermittelt, bitte warten ..."
' x Leerzeilen vor lngLastMerkRow eintragen
' +1 für Leerzeile auf Folgeseite
intZeilen = 0
Do While Not (Rows(lngLastMerkRow + intZeilen).PageBreak = _
xlPageBreakAutomatic)
Rows(lngLastMerkRow + intZeilen).Insert
With Range(lngLastMerkRow + intZeilen & ":" & lngLastMerkRow + intZeilen)
.RowHeight = ActiveSheet.StandardHeight ' 15.75 Zeilenhöhe
.VerticalAlignment = xlCenter ' vertikale Ausrichtung: Mitte
With Range("B" & lngCurRow & ":" & "C" & lngCurRow)
.IndentLevel = 1 ' muss wieder gesetzt werden
End With
.Font.Name = "Times New Roman" ' Alles auf Times setzen
.Font.Size = 12
.Font.Bold = False
.Font.Italic = False
.Font.Underline = xlUnderlineStyleNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
End With
intZeilen = intZeilen + 1
lngLastRow = lngLastRow + 1
Loop
lngErsteZeileaufSeite = lngLastMerkRow + intZeilen
lngCurRow = lngLastMerkRow + intZeilen + 1
Else
If IsDate(Range("A" & lngCurRow)) Then
' Neuer Datensatz, also Zeiger neu setzen
lngErsteZeileaufSeite = lngCurRow
lngLastMerkRow = lngCurRow
End If
lngCurRow = lngCurRow + 1
End If
Wend
End Sub
Viel Spaß
Frank.