Alles ausserh. Druckbereich im ganzen WB löschen

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter!
Das sollte es tun.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub AllesAusserDruckbereichLöschen()
Dim objWS As Worksheet
Dim rng As Range
Dim lngFirst As Long, lngLast As Long
Dim intFirst As Integer, intLast As Integer

On Error GoTo ErrExit

GetMoreSpeed

For Each objWS In ThisWorkbook.Worksheets

  With objWS

    Set rng = .Range(.PageSetup.PrintArea)

    If Not rng Is Nothing Then

      If rng.Areas.Count = 1 Then

        lngFirst = rng(1).Row
        intFirst = rng(1).Column
        lngLast = rng(rng.Count).Row
        intLast = rng(rng.Count).Column

        If lngLast < .Rows.Count Then .Range(.Cells(lngLast + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Delete
        If lngFirst > 1 Then .Range(.Cells(1, 1), .Cells(lngFirst - 1, .Columns.Count)).Delete
        If intLast < .Columns.Count Then .Range(.Cells(1, intLast + 1), .Cells(.Rows.Count, .Columns.Count)).Delete
        If intFirst > 1 Then .Range(.Cells(1, 1), .Cells(.Rows.Count, intFirst - 1)).Delete

      End If

    End If

  End With

Next

ErrExit:

GetMoreSpeed 0

Set rng = Nothing
End Sub

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc > 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Sub AllesAusserDruckbereichLöschen() Dim wb As Workbook, wsh As Worksheet, db As Range Dim ez As Long, lz As Long, es As Integer, ls As Integer Set wb = ThisWorkbook For Each wsh In wb.Worksheets Set db = wsh.Range(wsh.PageSetup.PrintArea) If db.Areas.Count > 1 Then Set wsh = Nothing Set db = Nothing Set wb = Nothing 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: wsh.Rows(lz + 1 & ":" & wsh.Rows.Count).Delete 'rechts löschen: wsh.Range(Cells(1, ls + 1), Cells(1, Columns.Count)).EntireColumn.Delete 'links löschen: If es > 1 Then _ wsh.Range(Cells(1, 1), Cells(1, es - 1)).EntireColumn.Delete 'oben löschen: If ez > 1 Then _ wsh.Rows("1:" & ez - 1).Delete Next wsh Set wsh = Nothing Set db = Nothing Set wb = Nothing End Sub

Sub AllesAusserDruckbereichLöschen() Dim db As Range Dim ez As Long, lz As Long, es As Integer, ls As Integer --- Dim sh as worksheet --- for each sh in activeworkbook.sheets --- sh.select 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 --- mext End Sub

Beliebteste Forumthreads (12 Monate)

Alles ausserh. Druckbereich im ganzen WB löschen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread