Finden von Mehrfacheinträge beschleunigen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub test() Dim delRng As Range Dim c As Long Dim lRow As Long ' zu prüfende Spalte, mußte ich zum Test so einsetzen Const b = 2 lRow = Cells(Rows.Count, 1).End(xlUp).Row For c = 2 To lRow If WorksheetFunction.CountIf(Range(Cells(2, b), Cells(lRow, b)), Cells(c, b)) = 1 Then If delRng Is Nothing Then Set delRng = Rows(c) Else Set delRng = Union(delRng, Rows(c)) End If End If Next c Application.ScreenUpdating = False If Not delRng Is Nothing Then delRng.Delete Application.ScreenUpdating = True End Sub

Sub Leerzeilen_loeschen() ' alle Leerzeilen löschen Dim LoI As Long Dim RaZeile As Range Application.ScreenUpdating = False For LoI = 1 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row If Application.WorksheetFunction.CountA(Rows(LoI)) ActiveSheet.UsedRange. _ SpecialCells(xlCellTypeLastCell).Column Then If Rows(LoI).SpecialCells(xlCellTypeBlanks).Count = ActiveSheet.UsedRange. _ SpecialCells(xlCellTypeLastCell).Column Then If RaZeile Is Nothing Then Set RaZeile = Rows(LoI) Else Set RaZeile = Union(RaZeile, Rows(LoI)) End If End If End If Next LoI If Not RaZeile Is Nothing Then RaZeile.Delete Application.ScreenUpdating = True Set RaZeile = Nothing End Sub

Public Sub Neuer_Versuch() Dim lRow As Long Dim lZeile As Long Dim rZeile As Range lRow = Cells(Rows.Count, 1).End(xlUp).Row For lZeile = lRow To 2 Step -1 If WorksheetFunction.CountIf(Range(Cells(2, b), Cells(lRow, b)), Cells(lZeile, b)) = 1 _ Then If rZeile Is Nothing Then Set rZeile = Rows(lZeile) Else Set rZeile = Union(rZeile, Rows(lZeile)) End If End If Next lZeile If Not rZeile Is Nothing Then rZeile.Delete ' Zeilen löschen Set rZeile = Nothing End Sub

Hi
die schnellste Variante ist folgende, diese Variante funktioniert auch mit beliebigen Datenmengen und ist bei grossen Datenmengen auch von Hand schneller als die meisten Makros, die auf Schleifen basieren:
1. Daten nach der Spalte mit dem Vergleichskriterium sortieren (in diesem Fall Spalte b)
2. am Tabellenende folgende Formel eintragen (Formel ist geschrieben für die Zeile 2, da ich von einer Überschrift ausgehe: =Wenn(Oder(B1=B2;B2=B3);Zeile();"")

3.mit Kopieren - Inhalte einfügen - Werte die Formel fixieren
4. Datei nach der neuen Spalte sortieren.
5. in der neuen Spalte die leeren Zellen selektiern und dann die ganze Zeile löschen (geht über BEARBEITEN - GEHE ZU - INHALTE - LEERZELLEN, anschließend BEARBEITEN - ZELLEN LÖSCHEN - GANZE ZEILE)
als Makro sieht das ganze so aus:

Sub EinfacheLöschen()
Const b = 2 'hier die Spalte mit den Vergleichswerten eintragen
With ActiveSheet.UsedRange
.Sort Key1:=Cells(b, 2), order1:=xlAscending, header:=xlYes
With .Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 1)
.FormulaR1C1 = "=if(or(R[-1]C" & b & "=RC" & b & ",R[1]C" & b & "=RC" & b & "),Row(),""" _
")"
.Formula = .Value
.EntireRow.Sort Key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
.Delete
End With
End With
End Sub

Gruß, Daniel

Sub EinfacheLöschen() Const b = 1 'hier die Spalte mit den Vergleichswerten eintragen With ActiveSheet.UsedRange .Sort Key1:=Cells(2, b), order1:=xlAscending, header:=xlYes With .Columns(.Columns.Count).Offset(1, 1).Resize(.Rows.Count - 1, 1) .FormulaR1C1 = _ "=if(or(R[-1]C" & b & "=RC" & b & ",R[1]C" & b & "=RC" & b & "),Row(),"""")" .Formula = .Value .EntireRow.Sort Key1:=.Cells(1, 1), order1:=xlAscending, header:=xlNo On Error Resume Next .SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 .Delete End With End With End Sub

Beliebteste Forumthreads (12 Monate)

Finden von Mehrfacheinträge beschleunigen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread