Doppelte zeilen löschen

Sub DoppelteWerte_löschen() Application.ScreenUpdating = False Application.EnableEvents = False intRow = Cells(Rows.Count, 1).End(xlUp).Row For Start = intRow To 1 Step -1 If Not IsEmpty(Cells(Start, 1)) Then If Application.CountIf(Columns(1), Cells(Start, 1)) > 1 Then Cells(Start, 1).ClearContents End If End If Next Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim i As Long Dim lz As Integer Dim raus As Range Application.ScreenUpdating = False lz = Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To lz If Application.CountIf(Columns(1), Cells(i, 1)) > 1 Then If raus Is Nothing Then Set raus = Cells(i, 1) Else Set raus = Union(raus, Cells(i, 1)) End If End If Next i If Not raus Is Nothing Then raus.ClearContents Application.ScreenUpdating = True

Option Explicit Sub DoppelteWerte_löschen() Application.ScreenUpdating = False Application.EnableEvents = False Dim RaZelle As Range Dim IntRow As Long Dim Start As Long IntRow = IIf(IsEmpty(Cells(Rows.Count, 1)), _ Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) For Start = IntRow To 1 Step -1 If Not IsEmpty(Cells(Start, 1)) Then If Application.CountIf(Columns(1), Cells(Start, 1)) > 1 Then If RaZelle Is Nothing Then Set RaZelle = Cells(Start, 1) Else Set RaZelle = Union(RaZelle, Cells(Start, 1)) End If End If End If Next If Not RaZelle Is Nothing Then RaZelle.ClearContents Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Option Explicit Sub DoppelteWerte_löschen() Application.ScreenUpdating = False Application.EnableEvents = False Dim RaZelle As Range Dim IntRow As Long Dim Start As Long IntRow = IIf(IsEmpty(Cells(Rows.Count, 1)), _ Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) For Start = IntRow To 1 Step -1 If Not IsEmpty(Cells(Start, 1)) Then If Application.CountIf(Range("A1:A" & Start), Cells(Start, 1)) > 1 Then If RaZelle Is Nothing Then Set RaZelle = Cells(Start, 1) Else Set RaZelle = Union(RaZelle, Cells(Start, 1)) End If End If End If Next If Not RaZelle Is Nothing Then RaZelle.ClearContents Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Hallo Gregor,
eine offtopic-Anmerkung:
wie ist intRow denn dimensioniert? Die Notation sieht aus, als wäre es ein Integer. Solange deine Tabelle weniger als 32.767 Zeilen hat ist das unproblematisch, aber alleine da es in Excel die Möglichkeit gibt mehr Zeilen anzusprechen sollte jede sich auf Zeilen beziehende Variable schon aus Prinzip als Long dimensioniert - und dann auch entsprechend benannt (lngRow)werden.
Der Funktionalität deines Codes tut das keinen Abbruch, es ist nur pedantisches Geschwätz!
Ontopic:
Eine Schleife über x-tausend Zeilen, in der am besten noch Operationen vorkommen, ist immer sehr langsam.
Die üblichen Verdächtigen Vorschläge wären jetzt: schalte xlCalculate aus, oder sammel die Zeilen in einem Union und lösche sie dann auf einen Schlag wenn die Schleife um ist, oder bastel dir die Bedingung zum Löschen in einer Hilfsspalte um den Löschbereich ohne Schleife per Autofilter oder Range().SpecialCells() rasend schnell zu löschen.
Aber Hajo hat da schon recht: Es gibt in Excel (seit 2007?) die Funktion "Doppelte löschen". Diese einmal durch den Makrorekorder, dann hast du den schnellstmöglichen Code.
Was Hajo nicht bedacht hat: "Doppelte löschen" entfernt die gesamte Zeile. Dein Code behält die Zeilen (da du .ClearContent statt .Delete nutzt) und leert nur die Inhalte.
Es ist etwas kontra-intuitiv dass deine Schleife rückwärts läuft (step -1), da deine CountIf Abfrage eh die gesamte Spalte abfragt und dieser relativ egal ist, ob sie von oben oder von unten prüft. Aber wir kennen ja deine restliche Datenstruktur nicht, vielleicht sind unten ja "ältere" Daten in den anderen Spalten? Ausserdem hast du "löschen" statt "leeren" im Betreff geschrieben. Ich nehme an Hajo hat sich dadurch ablenken lassen und deinen Code nicht so sorgfältig gelesen wie ein Antworter auf Spizenniveau es eigentlich machen sollte - bitte das nächste mal präzisere Fragen stellen, weil wir hier alle so pedantisch sind (siehe auch meine Ausführung weiter oben).
Also, Gregor, bitte eine kurze Rückmeldung:
1) hilft dir das Boardmittel "Duplikate Löschen" von Excel bereits weiter oder
2) brauchst du eine Makrolösung, die Zeilen nur leert und nicht löscht?
Wenn 2), dann bitte auch diese beantworten:
2a) es darf eine Hilfsspalte genutzt werden
2b) es darf ein Autofilter genutzt werden
2c) du lädst eine Musterdatei hoch, damit ich das nicht "blind" bauen muss.
Grüße,
Klaus M.vdT.

Hallo Gregor,
anbei die Musterdatei mit ein paar Makros
https://www.herber.de/bbs/user/84668.xlsm
(musste das Blatt 1 leer lassen, um im 300kb-Upload zu bleiben. Starte zunächst das Makro "wiederherstellen"!)
Ich habe alle Methoden im Thread ausprobiert, inklusive meiner Vorschläge (special cells und autofilter). Aus dem Bauch heraus würde ich sagen, dass Erichs Methode die beste ist da sie ohne Hilfsspalten auskommt und die wenigsten (langsamen) Operationen im Excelblatt selbst ausführt.
Wenn du die in meiner SpecialCells-Version erzeugten Formeln in einer Hilfsspalte direkt im Blatt stehen lassen kannst statt sie im Makro zu erzeugen, behaupte ich dass ist die schnellste Methode.
Seltsamerweise ist dein als langsam verschrieenes Original in der Musterdatei am schnellsten durchgelaufen:
'Zusammenfassung Zeiten:
'Autofilter-Methode: 0,78 sek
'SpecialCells-Methode: 0,39 sek
'Array-Methode (Erich): 0,39 sek
'Union-Zellen (Hajo und Hary): 0,59 sek
'Original-Methode: 0,34 sek
Warscheinlich hat das was mit berechungen usw. zu tuen ... probier doch die verschiedenen Methoden mal in deiner Masterdatei aus. Mich würd sehr interessieren, welche Methode bei dir am schnellsten läuft!
Grüße,
Klaus M.vdT.

Option Explicit Sub DoppelteWerte_löschen() Dim arrW, varW, zz As Long, rngDel As Range arrW = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row) varW = arrW(1, 1) For zz = 2 To UBound(arrW) If varW = arrW(zz, 1) Then If rngDel Is Nothing Then Set rngDel = Cells(zz, 1) Else Set rngDel = Union(rngDel, Cells(zz, 1)) End If Else varW = arrW(zz, 1) End If Next If Not rngDel Is Nothing Then rngDel.ClearContents End Sub

Sub DoppelteWerte_löschen2() Dim rngF As Range Set rngF = Cells(3, 23).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 2) With rngF .FormulaR1C1 = "=IF(RC1=R[-1]C1,"""",RC1)" .Copy Cells(3, 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False .ClearContents End With Cells(3, 1).Select End Sub

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelte zeilen löschen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

286 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread