Option Explicit
'----------------------------------------------------------------------
Sub LeerSpaltenUndZeilenAufraeumen()
'In der aktiven Arbeitsmappe alle Blätter aufraeumen:
'- leere Spalten löschen
'- Spalten mit weniger als 10 Einträgen löschen
'- leere Zeilen loeschen
Dim ws As Worksheet
'Für alle Blaetter in der aktiven Mappe
For Each ws In Worksheets
ws.Activate
Call ZellenMitNurBlancsLeeren3 '### geändert
Call LeereSpaltenLoeschen
Call SpaltenLoeschenBeiKleinerWerteanzahl
Call LeereZeilenLoeschen
Call DruckbereichAufBenutzteZellenFestlegen3 '### geändert
Next
Worksheets(1).Activate
End Sub
'----------------------------------------------------------------------
Private Sub LeereSpaltenLoeschen()
'löscht auf dem aktiven Blatt leere Spalten
'(Fehler 91 bei leerem Tabellenblatt)
On Error GoTo ErrorHandler
Dim x As Integer, actColNo As Integer
'Spaltenanzahl
actColNo = ActiveSheet.Cells.Find(*, [A1], , , xlByColumns, xlPrevious).Column
'Fuer alle Spalten
For x = actColNo To 1 Step -1
'Wenn keine Zellen mit Wert in der Spalte vorhanden ist -> Spalte loeschen
If (Application.CountA(Columns(x)) = 0) Then Columns(x).Delete
Next
Exit Sub
ErrorHandler:
If Err.Number <> 91 Then MsgBox (Unerwarteter Fehler bei 'LeereSpaltenLoeschen')
End Sub
'----------------------------------------------------------------------
Private Sub SpaltenLoeschenBeiKleinerWerteanzahl()
'löscht auf dem aktiven Blatt Spalten,
'die weniger als c_minAnzahlWerte Werte enthalten
'bei weniger als ... Werten in der Spalte wird diese gelöscht
Const c_minAnzahlWerte = 10
'(Fehler 91 bei leerem Tabellenblatt)
On Error GoTo ErrorHandler
Dim x As Integer, WerteAnzahlImBereich As Integer
Dim actColNo As Integer, actRowNo As Integer
actColNo = Cells.Find(*, [A1], , , xlByColumns, xlPrevious).Column
actRowNo = Cells.Find(*, [A1], , , xlByRows, xlPrevious).Row
For x = actColNo To 1 Step -1 '### geänder
WerteAnzahlImBereich = Application.CountA(Range(Cells(1, x), Cells(actRowNo, x)))
'Wenn keine Zellen mit Wert in der Spalte vorhanden ist -> Spalte loeschen
Dim i As Integer
Dim del As Boolean
del = False
For i = 1 To actRowNo 'geändert
If Not Cells(i, x).Value = Then '### geändert
del = False
Exit For
End If
del = True
Next i
If del Then Columns(x).Delete
Next
Exit Sub
ErrorHandler:
If Err.Number <> 91 Then MsgBox (Unerwarteter Fehler bei 'SpaltenLoeschenBeiKleinerWerteanzahl')
End Sub
'----------------------------------------------------------------------
Private Sub LeereZeilenLoeschen()
'löscht auf dem aktiven Blatt leere Zeilen
'(Fehler 91 bei leerem Tabellenblatt)
On Error GoTo ErrorHandler
Dim x As Integer, actRowNo As Integer, actColNo As Integer
'Zeilenanzahl
actRowNo = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
'Fuer alle Zeilen
For x = actRowNo To 1 Step -1 '### geändert
'Wenn keine Zelle mit Wert in der Zeile vorhanden ist -> Zeile loeschen
Dim i As Integer
Dim del As Boolean
del = False
actColNo = Cells.Find(*, [A1], , , xlByColumns, xlPrevious).Column
For i = 1 To actColNo '### geändert
If Not Cells(x, i).Value = Then '### geändert
del = False
Exit For
End If
del = True
Next i
If del Then Rows(x).Delete
'If (Application.CountA(Rows(x)) = 0) Then Rows(x).Delete
Next x
Exit Sub
ErrorHandler:
If Err.Number <> 91 Then MsgBox (Unerwarteter Fehler bei 'LeereZeilenLoeschen')
End Sub
'----### geändert------------------------------------------------------------------
Private Sub ZellenMitNurBlancsLeeren3()
'Zellen finden, die nur 1-5 Leerzeichen enthalten
'und deren Zellinhalt löschen
'
'(Fehler 91 bei leerem Tabellenblatt)
On Error GoTo ErrorHandler
Dim actColNo As Integer, actRowNo As Integer
Dim zelle As Object
Dim ersteAdresse As Variant
actColNo = ActiveSheet.Cells.Find(*, [A1], , , xlByColumns, xlPrevious).Column
actRowNo = ActiveSheet.Cells.Find(*, [A1], , , xlByRows, xlPrevious).Row
With ActiveSheet.Range(Cells(1, 1), Cells(actRowNo, actColNo))
Set zelle = .Find( , LookIn:=xlValues)
If Not zelle Is Nothing Then
ersteAdresse = zelle.Address
Do
If ( _
(zelle.Value = ) Or _
(zelle.Value = ) Or _
(zelle.Value = ) Or _
(zelle.Value = ) Or _
(zelle.Value = ) _
) Then
zelle.Value =
End If
Set zelle = .FindNext(zelle)
Loop While Not zelle Is Nothing And zelle.Address <> ersteAdresse
End If
End With
Exit Sub
ErrorHandler:
If Err.Number <> 91 Then MsgBox (Unerwarteter Fehler & Err.Number & _
bei 'ZellenMitNurBlancsLeeren')
End Sub
'-------### geändert---------------------------------------------------------------
Private Sub DruckbereichAufBenutzteZellenFestlegen3()
'legt den Druckbereich für das aktive Blatt auf den Bereich der benutzten Zellen fest
'
'Abhilfe für:
' Sind in einem Excelblatt Rahmen bei markierter Spalte(n) bzw. Zeile(n) angelegt
'(Zellen formatieren -> Rahmen)und danach Zellen unter/neben dem benutzten Bereich
' auf diesen Spale(n)/Zeile(n) angeklickt worden, werden beim Drucken am Ende bzw.
' neben des/dem benutzten Bereich leere umrahmte Zellen ausgedruckt.
'
'(Fehler 91 bei leerem Tabellenblatt)
On Error GoTo ErrorHandler
Dim actColNo As Integer, actRowNo As Integer
actColNo = ActiveSheet.Cells.Find(*, [A1], , , xlByColumns, xlPrevious).Column
actRowNo = ActiveSheet.Cells.Find(*, [A1], , , xlByRows, xlPrevious).Row
Range(Cells(1, 1), Cells(actRowNo, actColNo)).Select
ActiveSheet.PageSetup.PrintArea = Selection.Address
Exit Sub
ErrorHandler:
If Err.Number <> 91 Then MsgBox (Unerwarteter Fehler & Err.Number & _
bei 'DruckbereichAufBenutzteZellenFestlegen')
End Sub
freuen, wenn mir da einer weiter helfen könnte!
