AW: Duplikate entfernen
20.06.2015 19:32:59
Sepp
Hi,
70.000 Zeilen sind schon heftig! Dieser Code schaft auf meinem betagten Laptop die 70.000 Zeilen und 33.000 gelöschte Datensätze in 6 Minuten.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub removeDuplikates()
Dim lngLast As Long, lngI As Long
Dim vntDel As Variant, rng As Range
Dim lngCalc As Long
Dim t As Double
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
t = Now
Debug.Print t
With ActiveSheet
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
.Columns(1).Insert
vntDel = .Range(.Cells(2, 1), .Cells(lngLast, 1))
For lngI = 1 To UBound(vntDel, 1)
If Application.CountIf(.Range(.Cells(2, 2), .Cells(lngI, 2)), .Cells(lngI, 2)) > 1 Then
vntDel(lngI, 1) = "XXX"
End If
Next
.Range(.Cells(2, 1), .Cells(lngLast, 1)) = vntDel
On Error Resume Next
Set rng = .Columns(1).SpecialCells(2, 2)
If Not rng Is Nothing Then rng.EntireRow.Delete
Err.Clear
On Error GoTo ErrExit
.Columns(1).Delete
End With
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'removeDuplikates'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - removeDuplikates"
.Clear
End If
End With
On Error GoTo 0
Debug.Print Now - t
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
Set rng = Nothing
End Sub
Gruß Sepp