'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub Leerzeilenlöschen()
'On Error Resume Next
Dim r As Range
Dim col As New Collection

For Each r In ActiveSheet.UsedRange.EntireRow
          
If WorksheetFunction.CountBlank(Rows(r.Row)) = 256 Then
          col.Add r
          End If
Next

For Each r In col
    r.Delete
    Next

End Sub


Sub Leerzeilenlöschen_alt()
'ohne Worksheetfunction darf On Error nicht fehlen,
'da bei vollständig gefülltem UsedRange die Zeile
'anz= r.SpecialCells... einen Fehler erzeugt.
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
    anz = r.SpecialCells(xlCellTypeBlanks).Count
    If anz >= c_ges Then
          col.Add r
          End If
Next

For Each r In col
    r.Delete
    Next

End Sub