noch eine
13.09.2009 09:03:05
Tino
Hallo,
Version die die ganze Zeile prüft ob diese leer ist.
Function FindLetzte(mySH As Worksheet) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
With mySH.UsedRange
On Error Resume Next
'Finde Zeile
LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LRow = 0 Then LRow = 1
'Finde Spalte
For A = .Columns(.Columns.Count).Column To .Columns(1).Column Step -1
LCol = mySH.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Row
LCol = Application.Max(LCol, mySH.Columns(A).Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LCol > 1 Then: LCol = A: Exit For
Next A
If LCol = 0 Then LCol = 1
End With
Set FindLetzte = mySH.Cells(LRow, LCol)
End Function
Sub LoescheLeere()
Dim Bereich As Range
Dim iCalc As Integer
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
With Sheets("Tabelle1") 'Tabellenname anpassen
Set Bereich = FindLetzte(Sheets(.Name)) 'letzte Zelle finden
If Bereich.Row > 4 Then 'prüfen ob letzte erst ab Zeile 5
Set Bereich = .Range(.Cells(5, Bereich.Column), Bereich).Offset(0, 1)
Bereich.FormulaR1C1 = "=IF(COUNTIF(RC1:RC[-1],"""")<COLUMN()-1,ROW(),TRUE)"
.Range("A5", Bereich).Sort Key1:=Bereich(1, 1), Order1:=xlAscending, Header:=xlNo
On Error Resume Next
Bereich.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
On Error GoTo 0
Bereich.EntireColumn.Delete
End If
End With
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino