Mehrfach vorhandene Zellen löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MachDeinDing() Dim X As Integer, Zeile As Integer, T As String, SchonDa As String, Such As String Zeile = 1 For X = 1 To 1000 Such = Cells(Zeile, 1) & Cells(Zeile, 2) & "@" If InStr(SchonDA, Such) > 0 Then T = Trim$(Str$(Zeile)) & ":" & Trim$(Str$(Zeile)) Rows(T).Delete Shift:=xlUp Else SchonDa = SchonDa & Such Zeile = Zeile + 1 End If Next End Sub

Sub MachDeinDing() Dim X As Integer, Zeile As Integer, T As String, SchonDa As String, DieErsten As String, _ Such As String Zeile = 1 'Alles durchgehen und Mehrfache löschen bzw. erste festhalten For X = 1 To 1000 Such = "@" & Cells(Zeile, 1) & "@" & Cells(Zeile, 2) & "@" If InStr(SchonDa, Such) > 0 Then T = Trim$(Str$(Zeile)) & ":" & Trim$(Str$(Zeile)) Rows(T).Delete Shift:=xlUp If InStr(DieErsten, Such) = 0 Then DieErsten = DieErsten & Such Else SchonDa = SchonDa & Such Zeile = Zeile + 1 End If Next 'Alles durchgehen und die ehemals mehrfachen Ersten löschen For Zeile = 1 To Zeile If InStr(DieErsten, Such) > 0 Then T = Trim$(Str$(Zeile)) & ":" & Trim$(Str$(Zeile)) Rows(T).Delete Shift:=xlUp End If Next End Sub

Sub MachDeinDing() Dim X As Integer, Zeile As Integer, T As String, SchonDa As String, DieErsten As String, _ Such As String Zeile = 1 'Alles durchgehen und Mehrfache löschen bzw. erste festhalten Application.ScreenUpdating = False For X = 1 To 1000 Such = ",@" & Cells(Zeile, 1) & "@" & Cells(Zeile, 2) & "@" If InStr(SchonDa, Such) > 0 Then Rows(Zeile).Delete Shift:=xlUp If InStr(DieErsten, Such) = 0 Then DieErsten = DieErsten & Such Else SchonDa = SchonDa & Such Zeile = Zeile + 1 End If Next 'Alles durchgehen und die ehemals mehrfachen Ersten löschen For Zeile = 1 To Zeile Such = ",@" & Cells(Zeile, 1) & "@" & Cells(Zeile, 2) & "@" If InStr(DieErsten, Such) > 0 Then Rows(Zeile).Delete Shift:=xlUp End If Next Application.ScreenUpdating = True End Sub

Sub test() Dim z1 As Long, z2 As Long z1 = ActiveSheet.UsedRange.Row z2 = ActiveSheet.UsedRange.Rows.Count Range("A:B").Insert Cells(z1, 2).Resize(z2, 1).FormulaR1C1Local = "=ZS(1)&ZS(2)" Cells(z1, 1).Resize(z2, 1).FormulaR1C1Local = "=WENN(ZÄHLENWENN(S(1);ZS(1))>1;WAHR;ZEILE())" With Cells(z1, 1).Resize(z2, 2) .Formula = .Value .EntireRow.Sort key1:=Cells(z1, 1) On Error Resume Next .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete On Error GoTo 0 .EntireColumn.Delete End With End Sub

Hallo Daniel (oder Karl-Heinz, bin grad etwas verwirrt)
das von dir hochgeladene Makro ist nicht von Volti, sondern von mir, deinem Namensvetter.
ich dachte, ich hätte schon beschrieben, wie ich die Daten lösche:


Sub test()
Dim z1 As Long, z2 As Long
z1 = ActiveSheet.UsedRange.Row
z2 = ActiveSheet.UsedRange.Rows.Count
Range("A:B").Insert
Cells(z1, 2).Resize(z2, 1).FormulaR1C1Local = "=ZS(1)&ZS(2)"
Cells(z1, 1).Resize(z2, 1).FormulaR1C1Local = "=WENN(ZÄHLENWENN(S(1);ZS(1))>1;WAHR;ZEILE())"
With Cells(z1, 1).Resize(z2, 2)
.Formula = .Value
.EntireRow.Sort key1:=Cells(z1, 1) '--- kann weggelassen werden, dann wirds bei grossen  _
Tabellen langsamer
On Error Resume Next
.SpecialCells(xlCellTypeConstants, 4).select ' --- diese Zeile ist nur nur zur  _
Verdeutlichung im Einzelstepmodus
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
On Error GoTo 0
.EntireColumn.Delete
End With
End Sub

lass mal diesen Code im Einzelstep-Modus durchlaufen, schau dir auch die eingefühgten Formeln an und du wirst verstehen was passiert:
ich füge eine Formel ein, die alle Zeilen, die gelöscht werden sollen, mit einem Wahrheitswert kennzeichnet.
Zellen, die einen Wahrheitswert enthalten, kann man über BEARBEITEN - GEHE ZU - INHALTE gezielt selektieren und dann löschen.
Ganz einfach.
Das Sortieren ist zwar nicht zwingened erforderlich, aber es beschleuinigt den Löschvorgang ungemein, wenn alle zu löschenden Zelllen direkt untereinander stehen.
dh. wenn du von 1000 Zeilen jede 2. Löschen willst, dann sind das für Excel immer 500 einzelne Löschaktionen.
sortierst du aber um, so daß du die Zeilen 1-500 löschen kannst, ist es nur eine Löschaktion.
Gruß, Daniel

Hallo,
das Script von Daniel funkltioniert einwandfrei. Wie vielleicht einige bereits wissen möchte im Anschluss noch sämtliche Unikate aus Spalte L(12) markieren und sortieren.
Jetzt ist mir eingefallen, dass ich doch eigentlich im Anschluss der Markierung der Spallte die _ >1 mal in Spalte A(1) und B(2) vorkommen noch eine Abfrage nach wahr und falsch für Werte in Spalte L(12) die =1 (Unikate) sind mache. Die Abfrage müsste ja dann ähnlich wie der von Daniel laute nur mit =1 statt >1 lauten


"=WENN(ZÄHLENWENN(S(1);ZS(1))=1;WAHR;Zeile())"

Am Ende sollten dann alle Doppelt in Spalte A und B sowie im Anschluss alle Einfach in Spalte L vorkommenden mit Wahr gekennzeichnet und nach unten sortiert sein damit sie zum Schluss auf einen Rutsch löschen kann. Also genauso wie in Daniels Makro nur noch mit Erweiterung.
Range("A:B").Insert
Cells(z1, 2).Resize(z2, 1).FormulaR1C1Local = "=ZS(1)&ZS(2)"
Cells(z1, 1).Resize(z2, 1).FormulaR1C1Local = "=WENN(ZÄHLENWENN(S(1);ZS(1))>1;WAHR;Zeile())"
With Cells(z1, 1).Resize(z2, 2)
.Formula = .Value
.EntireRow.Sort key1:=Cells(z1, 1)
On Error Resume Next
.SpecialCells(xlCellTypeConstants, 4).Select ' Einzelstepinfo
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
On Error GoTo 0
.EntireColumn.Delete
End With
End Sub

Sub test() Dim z1 As Long, z2 As Long z1 = ActiveSheet.UsedRange.Row z2 = ActiveSheet.UsedRange.Rows.Count Range("A:B").Insert Cells(z1, 2).Resize(z2, 1).FormulaR1C1Local = "=ZS(1)&ZS(2)" Cells(z1, 1).Resize(z2, 1).FormulaR1C1Local = "=WENN(ZÄHLENWENN(S(1);ZS(1))>1;WAHR;Zeile())" With Cells(z1, 1).Resize(z2, 2) .Formula = .Value .EntireRow.Sort key1:=Cells(z1, 1) On Error Resume Next .SpecialCells(xlCellTypeConstants, 4).Select .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete On Error GoTo 0 .EntireColumn.Delete End With Range("A:B").Insert Cells(z1, 2).Resize(z2, 1).FormulaR1C1Local = "=ZS(2)" Cells(z1, 1).Resize(z2, 1).FormulaR1C1Local = "=WENN(ZÄHLENWENN(S(1);ZS(1))=1;WAHR;Zeile())" 'Wenn ID einmal vorhanden With Cells(z1, 1).Resize(z2, 2) .Formula = .Value .EntireRow.Sort key1:=Cells(z1, 1) On Error Resume Next .SpecialCells(xlCellTypeConstants, 4).Select .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete On Error GoTo 0 .EntireColumn.Delete End With End Sub

Beliebteste Forumthreads (12 Monate)

Mehrfach vorhandene Zellen löschen

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread