Doppelte Zeilen finden bei 2 gleichen löschen

Sub Gleiche_Loeschen_SpalteA() Dim i As Long Dim lngLastR As Long lngLastR = Cells(Rows.Count, "A").End(xlUp).Row + 1 'Zellinhalte in Spalte A durch "" = Leerzelle ersetzen Do i = i + 1 Range(Cells(i + 1, "A"), Cells(lngLastR, "A")).Replace _ what:=Cells(i, "A").Value, replacement:="", lookat:=xlWhole Loop While WorksheetFunction.CountIf(Range(Cells(i + 1, "A"), Cells(lngLastR, "A")), "")

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
Zeilen löschen mit Bedingung macht man ab deiner Excelversion am einfachsten so:
1. am Tabellenende eine Formel hinschreiben, die alle Zeilen die gelöscht werden sollen mit 0 kennzeichnet und alle die stehen bleiben müssen mit der Zeilennummer.
für deinen Fall wäre das die Formel:

=Wenn(ZählenWenns(A:A;A1;C:C;C1)>1;0;Zeile())

die Formel trägt man dann bis zum Tabellenende ein
2. in die Überschriftenzeile der Hilfsspalte schreibt man immer die 0
3. Wende auf die ganze Tabelle die Funktion DATEN - DATENTOOLS - DUPLIKATE ENTFERNEN an.
Setze die Hilfsspalte als Kriterium ein und wähle die Option "keine Überschrift"
4. Lösche die Hilfsspalte
das geht auch per Code:

With ActiveSheet.UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=IF(CountIfs(C1,RC1,C3,RC3)>1,0,Row())"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .column, xlno
.ClearContents
End with
End with

diesen Code kannst du immer verwenden, wenn du die Aufgabe hast, Zeilen mit einer bestimmten Bedinung zu löschen.
Du musst lediglich die Formel entsprechend der Bedingung anpassen, der Rest des Codes ist immer der gleiche. Die Formel kannst du auch ohne VBA-Kenntnisse direkt in der Tabelle erstellen und solange daran rumdoktorn, bis sie das richtige Ergebnis liefert.
Mit dem Recorder kannst du dann das letzte Einfügen aufzeichnen, um so an den passenden Makrocode für die Formel zu erhalten.
Diese Methode ist daher absolut passend für dein VBA-Niveau, löscht die Zeilen aber auch bei größten Datenmengen mit Profigeschwindigkeit.
Gruß Daniel

Hallo Chris,
also die Unklarheiten verstehe ich jetzt gerade nicht. Der Code von Daniel ist doch bereits fertig und genau auf deine Bedürfnisse angepasst.
Du brauchst den Code doch nur in deinen bestehenden Code, nachdem dieser deinen Punkt 5 abgearbeitet hat einzufügen. Also Code von Daniel in deinen Code zwischen Punkt 5 und Punkt 7 einfügen.
Das Einzige das du gegebenenfalls noch anpassen musst ist folgendes:
Wenn du das Makro von einem anderen Tabellenblatt aus startest als das, auf dem die ganzen Anpassungen passieren, dann musst du das ActiveSheet rausnehmen und durch Sheets("Dein_Blatt_auf_dem_es_passiert") ersetzen.
Also dann so:

With Sheets("Dein_Blatt_auf_dem_es_passiert").UsedRange

Gruß Werner

Sub Sortieren() Columns("A:D").Select Selection.Sort Key1:=Range("B2"), order1:=xlAscending, header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Range("A1").Select End Sub

Sub DoppelteLöschen() Dim iRow As Long, iRowL As Long iRowL = Cells(Cells.Rows.Count, 1).End(xlUp).Row For iRow = iRowL To 1 Step -1 If WorksheetFunction.CountIf(Columns(1), Cells(iRow, 1)) > 1 Then Rows(iRow).Delete End If Next iRow End Sub

Sub Format() Range("A2:D65000").Select With Selection.Font .Name = "Arial" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Range("A1").Select End Sub

Sub DoppelteLöschen() With ActiveSheet.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(CountIfs(C1,RC1,C3,RC3)>1,0,Row())" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo ´hier passiert der Fehler .ClearContents End With End With End Sub

Sub DoppelteLöschen() With ActiveSheet.UsedRange .Sort Key1:=.Cells(1, 1), order1:=xlAscending, _ Key2:=.Cells(1, 3), order2:=xlAscending, Header:=xlYes With .Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 1) .FormulaR1C1 = _ "=IF(OR(AND(RC1=R[1]C1,RC3=R[1]C3),AND(RC1=R[-1]C1,RC3=R[-1]C3)),1,"""")" .Formula = .Value If WorksheetFunction.Sum(.Cells) > 0 Then .EntireRow.Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete End If .ClearContents End With End With End Sub

Beliebteste Forumthreads (12 Monate)

Doppelte Zeilen finden bei 2 gleichen löschen

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelte Zeilen finden bei 2 gleichen löschen

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread