Aufeinanderfolgende gleiche Daten löschen, aber nur wenn sie aufeinander folgen.

Question

Hi,

ich hab hier eine Tabelle mit einer Spalte mit Wortphrasen drin, also Kombinationen von Wörtern.

In dieser Tabelle kommen bestimmte Phrasen ab und an mehrfach hintereinander vor, diese will ich eliminieren.

Also nicht wie in Excel 2007 möglich die Duplikatsuche und dann Duplikate entfernen, da dann alle Vorkommen gelöscht werden ich aber eigentlich wissen will wie oft eine Phrase vorkommt, aber eben diese aufeinanderfolgenden Mehrfachvorkommen nicht mitzählen möchte.

Als Beispiel vielleicht mal ein paar Daten:

formatieren
rundll
PDF to Word
xp friert ein
PDF to Word
iso
w-lan ohne router
avi zu mpg
Skype
PDF to Word
PDF to Word
PDF to Word

Hier sollte also "PDF to Word" am Ende nicht drei mal gezählt werden sondern das zweite und dritte Vorkommen gelöscht werden.

Ergebnis sollte dann sein:

formatieren
rundll
PDF to Word
xp friert ein
PDF to Word
iso
w-lan ohne router
avi zu mpg
Skype
PDF to Word

Richtig toll wäre es wenn man noch den Abstand eingeben könnte unter dem Doppelungen gelöscht werden.

Also dass auch Zeilen gelöscht werden wenn die Vorkommen nicht direkt nacheinander sondern eben erst x Zeilen danach auch noch vorkommen.

Hoffe ich hab mich verständlich ausgedrückt.

Gruß Fabian

Answer 1

Hi rainberg und Danke für die "Nachhilfe",

jetzt funktioniert es auch für mich Unwissenden ;-)

Gruß Fabian

Answer 2

hallo,

eine verbesserte Version

Sub Doppelte_direkt()
Dim max As Integer, i As Integer, j As Integer
max = InputBox("maximalen Abstand der doppelten Werte eingeben", , Pnr)
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If i <= max Then max = i - 1
For j = 1 To max
If Range("A" & i).Value = Range("A" & i - j).Value Then
Range("A" & i).Select
Selection.EntireRow.Delete
Exit For
End If
Next j
Next i
End Sub

Gruß

Helmut

Answer 3

hi all ^^

ein beispiel

gruss nighty

Option Explicit
Sub Loeschen()
Dim SpAzeile As Long, IndexDurchlauf As Long, IndexNeuArrAlty As Long
SpAzeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ReDim ArrAlt(SpAzeile, 1) As Variant
ReDim ArrNeu(SpAzeile, 1) As Variant
ArrAlt() = Range("A1:A" & SpAzeile)
Range("A2:A" & SpAzeile) = ""
ArrNeu() = Range("A1:A" & SpAzeile)
For IndexDurchlauf = 2 To SpAzeile
If ArrAlt(IndexDurchlauf, 1) <> ArrAlt(IndexDurchlauf - 1, 1) Then
IndexNeuArrAlty = IndexNeuArrAlty + 1
ArrNeu(IndexNeuArrAlty, 1) = ArrAlt(IndexDurchlauf, 1)
End If
Next IndexDurchlauf
Range("A2:A" & SpAzeile) = ArrNeu()
End Sub

Answer 4

hi helmut ^^

die selectionen sind aber nicht so schoen :-))

gruss nighty

Answer 5

hallo @nighty,

doch wieder mosern, deine Mittelungen sind wenig konstruktiv, da du keine genauen Angaben für bessere Ausführungen machst. Du wirfst nur Brochen in den Raum was dir nicht gefällt, ich erhebe mit meinen Vorschlägen keien Anspruch auf Perfektion. Dies ist Sache des Nutzers.

Range("A" & i).Select
Selection.EntireRow.Delete

Hier wäre es auch so zu lösen

Range("A" & i)..EntireRow.Delete


Gruß

Helmut

Answer 6

Hallo,

kleine Berichtigung, nicht so

Range("A" & i)..EntireRow.Delete

sondern so

Range("A" & i).EntireRow.Delete


Gruß

Helmut