Zeilen nach mehren Kriterien löschen

Guten Morgen,
ich verzweifle gerade an einer Aufgabe Zeilen aus einer Tabelle zu löschen die bestimmten Kriterien nicht entsprechen. Hier hat bestimmt jemand eine Idee.
Die erste Spalte der Tabelle enthält Ziffern zwischen 1 und 5 in zufälliger Reihenfolge. Die zweite Spalte den Wert rot, blau ober -. Ich möchte alle Zeilen löschen, die nicht den folgenden Kriterien entsprechen.
Spalte A: Wert 5 und Spalte B: blau oder rot.
Spalte A: Wert 4 und eine Zeile darunter Spalte A Wert 5 und Spalte B (auch Zeile darunter) Wert rot oder blau.
Spalte A: Wert 3 und zwei Zeilen darunter Spalte A Wert 5 und Spalte B Wert rot oder blau.
Spalte A: Wert 2 und drei Zeilen darunter Spalte A Wert 5 und Spalte B Wert rot oder blau.
Beispieldatei:
https://www.herber.de/bbs/user/140723.xlsx
Für eine Hilfestellung wäre ich sehr dankbar.
Grüße
Werner

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
warum die erste Zeile stehen bleiben soll ist mir nicht ersichtlich.
In ein Modul:


Sub Kill_rows()
Dim LR As Long, i As Long, SP As Integer, Z1 As Integer
Dim SpTmp As Integer
SP = 1 'Daten in Spalte A
Z1 = 2 'Daten ab Zeile xx
With Sheets("Tabelle1")
LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
SpTmp = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1 'erste freie Spalte des  _
gesamten Blattes
For i = Z1 To LR
Select Case .Cells(i, SP)
Case 5
If .Cells(i, SP + 1) = "blau" Or .Cells(i, SP + 1) = "rot" Then
.Cells(i, SpTmp) = 1 'bleibt
End If
Case 4
If .Cells(i + 1, SP) = 5 And (.Cells(i + 1, SP + 1) = "blau" Or .Cells(i +  _
1, SP + 1) = "rot") Then
.Cells(i, SpTmp) = 1 'bleibt
End If
Case 3
If .Cells(i + 2, SP) = 5 And (.Cells(i + 2, SP + 1) = "blau" Or .Cells(i +  _
2, SP + 1) = "rot") Then
.Cells(i, SpTmp) = 1 'bleibt
End If
Case 2
If .Cells(i + 3, SP) = 5 And (.Cells(i + 3, SP + 1) = "blau" Or .Cells(i +  _
3, SP + 1) = "rot") Then
.Cells(i, SpTmp) = 1 'bleibt
End If
End Select
Next
.Cells(1, SpTmp) = "TMP"
If WorksheetFunction.CountBlank(.Cells(Z1, SpTmp).Resize(LR - Z1 + 1, 1)) > 0 Then
.Columns(SpTmp).AutoFilter Field:=1, Criteria1:="="
.Rows(Z1).Resize(LR - Z1 + 1).Delete Shift:=xlUp
End If
.Columns(SpTmp).Delete
End With
End Sub>/pre>
LG UweD

Sub Unit() Dim lngZeile As Long, lngZeile2 As Long, rngDel As Range Set rngDel = Rows(Rows.Count) For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 lngZeile2 = lngZeile + 5 - Cells(lngZeile, 1).Value Select Case Cells(lngZeile, 1).Value Case 2 To 5 Select Case Cells(lngZeile2, 2).Value Case "blau", "rot" Case Else: Set rngDel = Union(rngDel, Rows(lngZeile)) End Select Case Else: Set rngDel = Union(rngDel, Rows(lngZeile)) End Select Next rngDel.Delete Set rngDel = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen nach mehren Kriterien löschen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread