AW: Automatisiert Zeilen Löschen
18.05.2009 09:29:05
Tino
Hallo,
versuche es mal hiermit.
Es werden zwei Hilfsspalten am Ende der Tabelle verwendet,
diese werden zum Schluss wieder gelöscht.
Ich gehe davon aus, dass in Zeile 1 eine Überschrift steht und die Daten ab Zeile 2 beginnen.
Sub Loeschen()
Dim Bereich As Range, SortBereich As Range
Dim iCalc As Integer
Dim LRow As Long
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
LRow = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row
Set Bereich = Range("A2", Cells(LRow, 1))
Set Bereich = Bereich.Offset(0, Columns.Count - Bereich.Column)
Set SortBereich = Bereich.Offset(0, -1)
SortBereich.FormulaR1C1 = "=ROW()"
Bereich.FormulaR1C1 = "=IF(MOD(ROW(),2)=1,0,"""")"
If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
Set SortBereich = Range("A2", Bereich.Cells(Bereich.Cells.Count))
SortBereich.Sort SortBereich(1, Columns.Count), xlAscending, , , , , , xlNo
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
SortBereich.Sort SortBereich(1, Columns.Count - 1), xlAscending, , , , , , xlNo
End If
Columns(Columns.Count).Delete
Columns(Columns.Count - 1).Delete
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino