AW: Zeilen nach Kriterum löschen
25.02.2008 16:34:00
Chris
Servus Immanuel,
ich erklär dir mal kurz, was da passiert (Anmerkungen in Makro1[Original]):
Sub Löschen()
Dim lngLetzteRow As Long, lngLetzteSpalte As Long
Dim lngSheet As Long
Dim iLauf As Integer
lngSheet = ThisWorkbook.Sheets.Count ' Sheets zählen
For iLauf = 1 To lngSheet 'Schleife, um Makro in jedem Sheet auszuführen
With Sheets(iLauf) ' mit dem aktuellen SHeet
lngLetzteRow = .Cells.Find(what:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' _
letzte beschriebene Zeile finden (auch Formeln mit "")
lngLetzteSpalte = .Cells.Find(what:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious). _
_
Column ' letzte beschriebene Spalte finden (auch Formeln mit "")
.Columns(lngLetzteSpalte + 1).Insert ' Einfügen einer Berechnungsspalte (hier kommen die _
Formeln rein)
On Error Resume Next ' falls Fehler nächstes ausführen
With .Range(.Cells(3, lngLetzteSpalte + 1), .Cells(lngLetzteRow, lngLetzteSpalte + 1)) 'In _
Berechnungsspalte
.FormulaR1C1 = "=IF(SUM(RC[" & -lngLetzteSpalte + 1 & "]:RC[-1])>0,Row(),True)" ' _
Summenformel einfügen (Wenn die Summe über die Zeile > 0 ist, dann, Zeilennummer, sonst TRUE,das True brauchen wir für die SpecialCells)
.Formula = .Value ' aus der Formel einen Wert machen
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete ' Zeilen mit True in _
Berechnungsspalte löschen
End With
On Error GoTo 0 ' falls Fehler zurücksetzen
.Columns(lngLetzteSpalte + 1).Delete ' Berechnungsspalte löschen
End With
Next iLauf
End Sub
so hier geht es um Schnelligkeit, deswegen auch keine Schleife über die einzelnen Zeilen. Wenn du aber jetzt in der letzten Zeile eine Zahl stehen hast, ist ja logischerweise die Summe > 0 und somit wird die zeile nicht gelöscht.
Der Ausdruck "*" steht nicht für den Stern, sondern als Lückenhalter für Text bzw. Zahlen. Wenn du die letzte Zeile auch noch löschen willst, dann solltest du sie mit X in Zelle A kennzeichenen statt mit * und folgendes in das Makro einfügen.
If .Range("A" & lngLetzteRow) = "X" Then
.Range("A" & lngLetzteRow).EntireRow.Delete
End if
Das sähe dann so aus:
Sub Löschen()
Dim lngLetzteRow As Long, lngLetzteSpalte As Long
Dim lngSheet As Long
Dim iLauf As Integer
lngSheet = ThisWorkbook.Sheets.Count
For iLauf = 1 To lngSheet
With Sheets(iLauf)
lngLetzteRow = .Cells.Find(what:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lngLetzteSpalte = .Cells.Find(what:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious). _
_
Column
.Columns(lngLetzteSpalte + 1).Insert
On Error Resume Next
With .Range(.Cells(3, lngLetzteSpalte + 1), .Cells(lngLetzteRow, lngLetzteSpalte + 1))
.FormulaR1C1 = "=IF(SUM(RC[" & -lngLetzteSpalte + 1 & "]:RC[-1])>0,Row(),True)"
.Formula = .Value
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
On Error GoTo 0
.Columns(lngLetzteSpalte + 1).Delete
lngLetzteRow = .Cells.Find(what:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' _
Neuzuweisung, da ja schon gelöschte Zeilen
If .Range("A" & lngLetzteRow) = "X" Then
.Range("A" & lngLetzteRow).EntireRow.Delete
End if
End With
Next iLauf
End Sub
Gruß
Chris