Im Laufe dieses Monats habe ich von Dan(?) einen Makro erhalten, der ermöglicht, dass in allen Tabellen eines Workbooks alle Zellen ausserhalb des Druckbereichs gelöscht werden und somit nur der Druckbereich bleibt.
Das funktioniert soweit; das einzige Problem ist, dass der Makro sehr lange läuft, wenn es sich um umfangreiche Tabellen handelt. Dies, da jede Zelle geprüft wird, ob diese innerhalb des Druckbereichs ist, und wenn dies nicht zutrifft, der Zellinhalt gelöscht wird.
Meine Frage: Ich möchte den Code gerne wie folgt modifizieren:
Makro stellt fest, wo der Druckbereich liegt.
Sofern es Spalten links davon gibt, werden diese gelöscht (nicht nur geleert)
Sofern es Spalten rechts davon gibt, werden diese gelöscht (nicht nur geleert)
Sofern es Spalten oberhalb davon gibt, werden diese gelöscht (nicht nur geleert)
Sofern es Spalten unterhalt davon gibt, werden diese gelöscht (nicht nur geleert)
Kann mir da jemand weiterhelfen?
Besten Dank, Peter
Aktueller Code:
ption Explicit
Public
Sub Nur_Druckbereich()
On Error GoTo Err_Nur_Druckbereich
Dim Wkb As Workbook
Dim Ws As Worksheet
Dim rngDruckBereich As Range
Set Wkb = ThisWorkbook
For Each Ws In Wkb.Worksheets
Application.StatusBar = "Alles ausserhalb Druckbereich wird in " & Ws.Name & " gelöscht"
'Prüfen ob in diesem Worksheet Druckbereich vorhanden
Set rngDruckBereich = Druckbereich(Ws)
If (Not rngDruckBereich Is Nothing) Then
'wenn ja, alle Zeilen und Spalten ausserhalb löschen
Call AllesAusserhalbDruckbereichLoeschen(rngDruckBereich)
End If
Next Ws
Exit Sub
Err_Nur_Druckbereich:
MsgBox Err.Description, vbCritical, "Error in Nur_Druckbereich"
End Sub
Public
Function Druckbereich(ByRef io_Worksheet As Worksheet) As Range
Dim strDruckBereich As String
Set Druckbereich = Nothing
strDruckBereich = io_Worksheet.PageSetup.PrintArea
On Error Resume Next
Set Druckbereich = io_Worksheet.Range(strDruckBereich)
End Function
Public
Sub AllesAusserhalbDruckbereichLoeschen(ByRef io_rngDruckBereich As Range)
Dim rngCell As Range
For Each rngCell In io_rngDruckBereich.Worksheet.UsedRange.Cells
If (Intersect(rngCell, io_rngDruckBereich) Is Nothing) Then rngCell.Clear
Next rngCell
End Sub