Excel Reihenfolge prüfen und doppelte Werte Löschen VBA

Question

Hallo zusammen,

ich versuche durch einen VBA-Programm die Reihenfolge der Spalte D zu prüfen.
Es sollte immer abwechselnd der Wert 13 und 6009 vorkommen. Allerdings kommt
in der eingelesenen CSV-Datei der Wert 6009 oftmals doppelt hintereinander vor,
trifft dies zu soll die komplette Zeile automatisch gelöscht werden.Ohne die
Reihenfolge der Zeilen zu ändern.

z.B.

Spalte
13
6009
13
6009
13
6009
6009 --> komplette Zeile soll gelöscht werden!
13
6009

Ich habe es über folgendes Programm versucht, das allerdings noch nicht
funktioniert, zu lösen:

Sub test()
Dim i As Integer
Dim n As Integer
i = Cells(Rows.Count, 1).End(xlUp).Row
For n = 1 To i
If Cells(n, 4).Value = 6009 And Cells(n + 1, 4).Value = 6009 Then
Rows(n).Select
Selection.Delete Shift:=xlUp
End
Next
End Sub

Kann mir hier jemand weiterhelfen?

Grüße Peter

Answer 1

hi Peter

war ja fast richtig ^^

gruss Nighty

Sub test()
Dim i As Integer 'Als Long deklarieren,variablen eindeutige namen geben
Dim n As Integer 'Als Long deklarieren,variablen eindeutige namen geben
i = Cells(Rows.Count, 1).End(xlUp).Row 'Die 1 in 4 korrigieren
For n = 1 To i
If Cells(n, 4).Value = 6009 And Cells(n + 1, 4).Value = 6009 Then
Rows(n).Select 'Selectionen vermeiden
Selection.Delete Shift:=xlUp 'Selectionen vermeiden
'Rows(n).Delete Shift:=xlUp
End 'Die syntax ist End if
Next
End 'Ein Modul wird mit End Sub beendet

Answer 2

hi Peter

ops ,das end sub war wohl von mir ein kopierfehler .-)

gruss nighty

Answer 3

hi Peter ^^

bei größeren Datenmengen wird dein makro zu langsam sein !
ich hab das mal beschleunigt !

gruss nighty

Sub Löschen()
Dim LetzteZeileSpD As Long, ArrInhalt As Long
Dim DatenD As Variant
LetzteZeileSpD = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
DatenD = Range("D2:D" & LetzteZeileSpD)
For ArrInhalt = 1 To LetzteZeileSpD - 2
If DatenD(ArrInhalt, 1) = 6009 And DatenD(ArrInhalt + 1, 1) = 6009 Then DatenD(ArrInhalt, 1) = True
Next ArrInhalt
Range("D2:D" & LetzteZeileSpD) = DatenD
Cells(1, 4).AutoFilter Field:=1, Criteria1:=True
Rows("2:" & LetzteZeileSpD).Delete Shift:=xlUp
Cells(1, 4).AutoFilter
End Sub