Verbesserung
21.11.2008 10:13:03
JogyB
Hallo.
Nochmal ein wenig verbessert, jetzt können die Suchbegriffe an beliebiger Stelle in Spalte 15 _
stehen
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
Gruss, Jogy