Zeilen löschen die >=0 und <=9

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub loeSchen() Dim i As Long With ActiveSheet For i = .Cells(Rows.Count, 11).End(xlUp).Row To 6 Step -1 If IsNumeric(.Cells(i, 11)) And Not IsEmpty(.Cells(i, 11)) Then If .Cells(i, 11).Value = 0 Then .Rows(i).Delete End If End If Next End With End Sub

Sub loeSchen() Dim i As Long Dim k As Long Dim exClude() As String Dim deLete As Boolean Dim checkValue As String ReDim exClude(0 To 0) Application.ScreenUpdating = False With ActiveSheet ' Ausnahmen aus Spalte 15 einlesen. ' Zeile 1 von Spalte 15 darf nicht leer sein! If .Cells(1, 15) "" Then ReDim exClude(1 To .Cells(Rows.Count, 15).End(xlUp).Row) For i = 1 To .Cells(Rows.Count, 15).End(xlUp).Row exClude(i) = .Cells(i, 15).Value Next End If For i = .Cells(Rows.Count, 11).End(xlUp).Row To 6 Step -1 ' Wenn Zelle in Spalte If IsNumeric(.Cells(i, 11)) And Not IsEmpty(.Cells(i, 11)) Then If .Cells(i, 11).Value = 0 Then ' Geht zunächst mal davon aus, dass gelöscht werden soll deLete = True ' Wenn Werte in Ausnahmeliste, dann ist die obere Grenze ' des Datenfeldes exClude > 0 --> Prüfung auf Ausnahmen If UBound(exClude) > 0 Then ' Zu testenden Wert in Spalte D zwischenspeichern (schneller) checkValue = .Cells(i, 4).Value ' Wert mit Ausnahmeliste vergleichen For k = 1 To UBound(exClude) ' Bei Übereinstimmung nicht löschen und Überprüfung abbrechen If checkValue = exClude(k) Then deLete = False Exit For End If Next End If ' Wenn Löschmarker noch gesetzt, dann löschen If deLete Then .Rows(i).deLete End If End If Next ' Schreibt Ausnahmeliste zur Sicherheit nochmal in Spalte 15 ' Ein Teil könnte gelöscht worden sein For i = 1 To UBound(exClude) .Cells(i, 15).Value = exClude(i) Next End With Application.ScreenUpdating = True End Sub

Sub loeSchen() Dim i As Long Dim k As Long Dim exClude() As String Dim deLete As Boolean Dim checkValue As String Dim leerZelle As Range Dim exCludeRange As Range Dim zeLLe As Range ReDim exClude(-1 To -1) Application.ScreenUpdating = False With ActiveSheet ' Beliebige leere Zelle in Spalte 15 finden (wenn Sheet ganz voll, dann geht's nicht) ' Wird für ColumnDifferences gebraucht Set leerZelle = Application.Columns(15).Find("") ' Ausnahmen aus Spalte 15 einlesen. 'On Error Resume Next Set exCludeRange = .Columns(15).ColumnDifferences(leerZelle) ' Wenn kein Fehler, dann wurden Suchbegriffe gefunden If Err.Number = 0 Then ' 2-dimensional wegen Zurückschreiben (s.u.) ReDim exClude(1 To exCludeRange.Cells.Count, 1 To 1) i = 0 For Each zeLLe In exCludeRange i = i + 1 exClude(i, 1) = zeLLe.Value Next End If For i = .Cells(Rows.Count, 11).End(xlUp).Row To 6 Step -1 ' Wenn Zelle in Spalte If IsNumeric(.Cells(i, 11)) And Not IsEmpty(.Cells(i, 11)) Then If .Cells(i, 11).Value = 0 Then ' Geht zunächst mal davon aus, dass gelöscht werden soll deLete = True ' Wenn Werte in Ausnahmeliste, dann ist die obere Grenze ' des Datenfeldes exClude > 0 --> Prüfung auf Ausnahmen If UBound(exClude, 1) > -1 Then ' Zu testenden Wert in Spalte D zwischenspeichern (schneller) checkValue = .Cells(i, 4).Value ' Wert mit Ausnahmeliste vergleichen For k = 1 To UBound(exClude) ' Bei Übereinstimmung nicht löschen und Überprüfung abbrechen If checkValue = exClude(k, 1) Then deLete = False Exit For End If Next End If ' Wenn Löschmarker noch gesetzt, dann löschen If deLete Then .Rows(i).deLete End If End If Next ' Schreibt Ausnahmeliste zur Sicherheit nochmal in Spalte 15 ' Ein Teil könnte gelöscht worden sein If UBound(exClude, 1) > -1 Then .Cells(1, 15).EntireColumn.ClearContents .Range(.Cells(1, 15), .Cells(UBound(exClude, 1), 15)).Value = exClude() End If End With Application.ScreenUpdating = True End Sub

Guten Abend Jogy,
das klappt mit einer Einschränkung, der Name
z.b. Terst... da werden auch die Zeilen der Die anderen Namen konnte ich nicht überprüfen, da hier mehr als >10 Tage drin steht.
Ich habe meine Tabelle verändert, die 1. Spalte rausgenommen, der Name steht jetzt in der
Spalte 3 (C) und die Anzahl steht in der Spalte 10 (J). In der Spalte 15 habe ich die Namen,
die ich auch abgekürzt habe. z.b. Müller GmbH u. Co KG habe ich Müll .
Hier das geänderte Makro:
Dim i As Long
Dim J As Long
Dim exClude() As String
Dim deLete As Boolean
Dim checkValue As String
Dim leerZelle As Range
Dim exCludeRange As Range
Dim zeLLe As Range
ReDim exClude(-1 To -1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveSheet
' Beliebige leere Zelle in Spalte 15 finden (wenn Sheet ganz voll, dann geht's nicht)
' Wird für ColumnDifferences gebraucht
Set leerZelle = Application.Columns(15).Find("")
' Ausnahmen aus Spalte 15 einlesen.
'On Error Resume Next
Set exCludeRange = .Columns(15).ColumnDifferences(leerZelle)
' Wenn kein Fehler, dann wurden Suchbegriffe gefunden
If Err.Number = 0 Then
' 2-dimensional wegen Zurückschreiben (s.u.)
ReDim exClude(1 To exCludeRange.Cells.Count, 1 To 1)
i = 0
For Each zeLLe In exCludeRange
i = i + 1
exClude(i, 1) = zeLLe.Value
Next
End If
For i = .Cells(Rows.Count, 10).End(xlUp).Row To 6 Step -1
' Wenn Zelle in Spalte
If IsNumeric(.Cells(i, 10)) And Not IsEmpty(.Cells(i, 10)) Then
If .Cells(i, 10).Value <= 9 And .Cells(i, 10).Value >= 0 Then
' Geht zunächst mal davon aus, dass gelöscht werden soll
deLete = True
' Wenn Werte in Ausnahmeliste, dann ist die obere Grenze
' des Datenfeldes exClude > 0 --> Prüfung auf Ausnahmen
If UBound(exClude, 1) > -1 Then
' Zu testenden Wert in Spalte D zwischenspeichern (schneller)
checkValue = .Cells(i, 3).Value
' Wert mit Ausnahmeliste vergleichen
For J = 1 To UBound(exClude)
' Bei Übereinstimmung nicht löschen und Überprüfung abbrechen
If checkValue = exClude(J, 1) Then
deLete = False
Exit For
End If
Next
End If
' Wenn Löschmarker noch gesetzt, dann löschen
If deLete Then .Rows(i).deLete
End If
End If
Next
' Schreibt Ausnahmeliste zur Sicherheit nochmal in Spalte 15
' Ein Teil könnte gelöscht worden sein
If UBound(exClude, 1) > -1 Then
.Cells(1, 15).EntireColumn.ClearContents
.Range(.Cells(1, 15), .Cells(UBound(exClude, 1), 15)).Value = exClude()
End If
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen löschen die >=0 und <=9

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

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread