Leere Zeilen löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Null_Löschen() Application.ScreenUpdating = False Dim lR%, i% lR = Cells(Rows.Count, 1).End(xlUp).Row For i = lR To 1 Step -1 If Cells(i, 1) = "0" Then Rows(i).Delete Next i Application.ScreenUpdating = True End Sub

Sub ZeilenMit0UnterhalbDesCursorsLöschen() Dim i As Integer For i = Cells(65536, ActiveCell.Column).End(xlUp).Row To ActiveCell.Row Step -1 If Not IsEmpty(Cells(i, ActiveCell.Column)) _ And Cells(i, ActiveCell.Column).Value = 0 Then Rows(i).Delete End If Next End Sub

Hallo, vielleich koente dies dir helfen. Grusse Dan.
'************************************
Option Explicit
Private Const TESTWERT As Variant = 0
' kann ales mogliche sein,
' es wird (als String) mit dem Value der Zelle (auch als String) verglichen
' falls der Wert in der Zelle gleich dem TESTWERT ist, wird die Zeile mit dieser Zelle geloscht
Private Const DURCHGESBEREICH As Variant = "A3:D5"
' DURCHGESBEREICH Settings :
' - um alle Zellen im UsedRange nach TESTWERT durchsuchen ............................. DURCHGESBEREICH = "alle"
' - um alle Zellen im Intersect von UsedRange und einer Spalte durschuchen,
' (Spalte wo sich die active Zelle gerade befindet) ................................... DURCHGESBEREICH = "actcell"
' - sonst eine String die als ein Bereich interpretiert werden kann, z.B. ............. DURCHGESBEREICH = "A3:D5"
Public Sub ZeilenLoschen()
Dim rDurchgesBereich As Range ' in diesem Bereich wird man nach TESTWERT suchen
Dim rZeilenZuLoschen As Range ' dieser Bereich sollte geloscht werden
Dim rZelle As Range

On Local Error GoTo ZeilenLoschen_Err

' wenn erfolgreich, returs Range wo nach TESTWERT gesucht wird
' sonst returns Nothing
Set rDurchgesBereich = SetBereichFurLoschen(DURCHGESBEREICH)

If (Not rDurchgesBereich Is Nothing) Then
For Each rZelle In rDurchgesBereich.Cells
If (CStr(rZelle.Value) = CStr(TESTWERT)) Then
If (rZeilenZuLoschen Is Nothing) Then
Set rZeilenZuLoschen = rZelle.EntireRow
Else
Set rZeilenZuLoschen = Application.Union(rZeilenZuLoschen, _
rZelle.EntireRow)
End If
End If
Next rZelle
If (Not rZeilenZuLoschen Is Nothing) Then rZeilenZuLoschen.Delete
Else
MsgBox "Bereich fur loschen nicht gefunden.", vbCritical, "Zeilen loschen"
End
End If

Exit Sub

ZeilenLoschen_Err:
MsgBox "Error : " & Err.Description, vbCritical, "Error"
End
End Sub


Private Function SetBereichFurLoschen(ByVal vTestBereich As Variant) As Variant
On Error GoTo SetBereichFurLoschen_Err
Set SetBereichFurLoschen = Nothing
Select Case CStr(vTestBereich)
Case "alle"
Set SetBereichFurLoschen = ActiveSheet.UsedRange
Exit Function
Case "actcell"
Set SetBereichFurLoschen = Application.Intersect(ActiveSheet.UsedRange, _
Columns(ActiveCell.Column))
Exit Function
Case Else
Set SetBereichFurLoschen = Range(CStr(vTestBereich))
Exit Function
End Select
Exit Function
SetBereichFurLoschen_Err:
End Function

' falls Fehler auftauchen sollten > DDMAIL@seznam.cz

Beliebteste Forumthreads (12 Monate)

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread