VBA: Druck leere Seiten unterbinden
EarnyToLearny
ich verwende die unten stehenden VBA-Anwendungen für die Druckausgabe. Dabei sollen die Seiten die keine Daten enthalten, auch nicht ausgedruckt werden. Funtioniert aber nur insoweit: wenn schon einmal 2 oder mehr Seiten ausgedruckt wurden (mit Daten), dann werden zukünftig auch leere Seiten ausgedruckt, obwohl nur eine Seite mit Daten gefüllt ist. (der Druckbereicht bleibt dann markiert).
Habe ich da etwas vergessen?
Dies steht in der Arbeitsmappe:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim WsA As Worksheet
Dim rngLC As Range
Set WsA = ActiveSheet
Set rngLC = LetzteZelle(WsA, 1)
If Not rngLC Is Nothing Then
Application.DisplayAlerts = False
WsA.PageSetup.PrintArea = WsA.Range("A1", rngLC).Address
Application.DisplayAlerts = True
Else
WsA.PageSetup.PrintArea = ""
Cancel = True
End If
End Sub
Dies steht in einem Modul:
Public Function LetzteZelle(oWs As Worksheet, _
Optional AnzahlUeberschriften As Long, _
Optional Bereich As Range) As Range
Dim iCol As Integer
Dim lRow As Long, lRowA As Long, lRowE As Long, lRowMax As Long
Dim rngC As Range, rngM As Range
iCol = 1
If Bereich Is Nothing Then Set Bereich = oWs.UsedRange
lRowA = Bereich.Row + AnzahlUeberschriften
lRowE = Bereich.Row + Bereich.Rows.Count - 1
For Each rngC In Bereich.Columns
For lRow = lRowE To lRowA Step -1
If Len(oWs.Cells(lRow, rngC.Column).MergeArea(1).Text) Then
iCol = rngC.Column
lRowMax = Application.WorksheetFunction.Max(1, lRow, lRowMax)
Exit For 'lRow
End If
Next lRow
Next rngC
If lRowMax = 0 Then Exit Function
Set rngM = Bereich.EntireColumn
'jetzt werden eventuell vorhandene Verbundene Zellen,
'die sich nach unten über den soeben ermittelten
'Bereich erstrecken, in diesen mit eingebunden:
Do
lRowE = lRowMax
Set Bereich = Application.Intersect(rngM, oWs.Rows(lRowMax))
For Each rngC In Bereich
With rngC
If .MergeCells Then
lRowMax = Application.WorksheetFunction.Max _
(1, .MergeArea.Row + .MergeArea.Rows.Count - 1, lRowMax)
End If
End With
Next rngC
Loop While lRowMax > lRowE
Set LetzteZelle = oWs.Cells(lRowMax, iCol)
End Function