Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
784to788
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
784to788
784to788
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

alles ausserhalb Druckbereich löschen

alles ausserhalb Druckbereich löschen
21.07.2006 09:19:13
Peter
Guten Tag
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: alles ausserhalb Druckbereich löschen
21.07.2006 09:32:29
Matthias
Hallo Peter,
teste mal:

Sub AllesAusserDruckbereichLöschen()
Dim db As Range
Dim ez As Long, lz As Long, es As Integer, ls As Integer
Set db = Range(ActiveSheet.PageSetup.PrintArea)
If db.Areas.Count > 1 Then
MsgBox "bei mehreren Bereichen nicht möglich!"
Exit Sub
End If
ez = db(1).Row
es = db(1).Column
lz = db(db.Count).Row
ls = db(db.Count).Column
Debug.Print ez, es, lz, ls
'unterhalb löschen:
Rows(lz + 1 & ":" & Rows.Count).Delete
'rechts löschen:
Range(Cells(1, ls + 1), Cells(1, Columns.Count)).EntireColumn.Delete
'links löschen:
If es > 1 Then _
Range(Cells(1, 1), Cells(1, es - 1)).EntireColumn.Delete
'oben löschen:
If ez > 1 Then _
Rows("1:" & ez - 1).Delete
End Sub

Gruß Matthias
Anzeige
AW: alles ausserhalb Druckbereich löschen
21.07.2006 09:52:05
Peter
Hallo Matthias
Die Lösung ist perfekt!
Vielen Dank.
Peter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige