Sub Zellen_loeschen()
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
End Sub
Sub Zellen_loeschen()
ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub
Sub Leerzeilenlöschen()
' Leerzeilen löschen einschließlich der Zeilen die entstehen wenn Zeilen am ende
' gelöscht werden, auch Leerzeilen in der Tabelle werden gelöscht
' von Wolf.W.Radzinski
' es wurden nicht alle Leerzeilen in einer Datei erkannt
' darum Ergänzung
On Error Resume Next
Dim r As Range
Dim anz As Long
Dim c_ges As Long
Dim col As New Collection
c_ges = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
For Each r In ActiveSheet.UsedRange.EntireRow
anz = 0
' ******** Hajo.Ziplies@web.de
Dim I As Byte
Dim L As Byte
L = 0
For I = 1 To 20
If Cells(r.Row, I) <> "" Then
L = 1
Exit For
End If
Next I
If L = 0 Then col.Add r
' anz = r.SpecialCells(xlCellTypeBlanks).Count
' If anz >= c_ges Then col.Add r
Next
For Each r In col
r.Delete
Next
End Sub
Sub Zeile_Verbergen()
' Zeile_Verbergen Makro
' Makro am 03.09.04 von Karius aufgezeichnet
Sheets("Tab").Activate
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Sheets("Tab").Select
For x = 5 To 800
Range("G" & x).Select
zellinhalt = ActiveCell.Text
If zellinhalt = "0" Then
Selection.EntireRow.Hidden = True
End If
Next
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("A4").Select
End Sub
Sub Zeilen_Öffnen()
Sheets("Tab").Select
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False
Rows("5:800").Select
Rows("5:800").EntireRow.AutoFit
Range("A4").Select
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'Worksheets("Eingabe").Activate
'Range("E8").Select
End Sub
Sub DelEmptyRows()
Dim s As Integer
Dim z9 As Long
Dim z1 As Long
Dim Appl As Application
Set Appl = Application
Appl.ScreenUpdating = False
Appl.Calculation = xlCalculationManual
With ActiveSheet.UsedRange
s = .Columns.Count
For z9 = .Rows.Count To 1 Step -1
z1 = z9
While Appl.CountBlank(.Rows(z9)) = s
z9 = z9 - 1
Wend
If z1 > z9 Then
Range(.Rows(z1).Row & ":" & .Rows(z9 + 1).Row).Delete
z9 = z9 + 1
End If
Next
End With
Appl.Calculation = xlCalculationAutomatic
Appl.ScreenUpdating = True
End Sub