Sub DoppelteEintraegeLoeschen()
 'Uwe Küstner, 20060514
 Dim colUnique As New Collection
 Dim lngAbZeile As Long
 Dim lngArr As Long
 Dim lngC As Long
 Dim lngCalc As Long
 Dim lngDup As Long
 Dim lngMaxArrays As Long
 Dim lngZ As Long
 Dim lngZeile As Long
 Dim lngZeilenArray As Long
 Dim lngZeilenBereich As Long
 Dim rngArea As Range
 Dim rngAuswahl As Range
 Dim rngC As Range
 Dim rngDel() As Range
 Dim rngSel As Range
 Dim strSuchbereich As String
 Dim strZeile As String
 Dim varAuswahl() As Variant
 Dim varC As Variant
 Set rngSel = Selection.EntireColumn
 lngZeilenBereich = ActiveSheet.UsedRange.Rows.Count
 On Error GoTo FehlerBehandlung
 lngCalc = Application.Calculation
 Set rngAuswahl = _
 Application.Intersect(Selection.EntireColumn, ActiveSheet.UsedRange)
 strSuchbereich = rngAuswahl.Address(0, 0)
 lngAbZeile = Abs(CLng(Application.InputBox( _
 vbLf & "Ab welcher Zeile soll geprüft werden?", _
 "Prüfbereich festlegen", 2, , , , , 1)))
 If lngAbZeile > 0 And lngAbZeile <= lngZeilenBereich Then
  Set rngAuswahl = _
  Application.Intersect(Rows(lngAbZeile & ":" & lngZeilenBereich), rngSel)
 Else
  MsgBox "Die Zeile " & lngAbZeile & _
  " liegt außerhalb des Bereichs """ & strSuchbereich & """!"
  Exit Sub
 End If
 lngZeilenArray = lngZeilenBereich - lngAbZeile + 1
 rngAuswahl.Select
 lngArr = 1
 ReDim rngDel(lngArr)
 lngMaxArrays = lngZeilenBereich / 50
 strSuchbereich = rngAuswahl.Address(0, 0)
 Application.Calculation = xlCalculationManual
 Application.ScreenUpdating = False
 For Each rngArea In rngAuswahl.Areas
  For Each rngC In rngArea.Columns
   lngC = lngC + 1
   ReDim Preserve varAuswahl(1 To lngC)
   varAuswahl(lngC) = rngC.Value
  Next rngC
 Next rngArea
 colUnique.Add 0, "" 'wenn 1. Leerzeile auch berücksichtigt werden soll
 For lngZeile = 1 To lngZeilenArray
  strZeile = ""
  For lngZ = 1 To lngC
   strZeile = strZeile & CStr(varAuswahl(lngZ)(lngZeile, 1))
  Next lngZ
  colUnique.Add lngZeile, strZeile
 Next lngZeile
 Set rngDel(0) = rngDel(1)
 lngArr = lngArr + (rngDel(lngArr) Is Nothing)
 If lngArr > 1 Then
  For lngZ = 2 To lngArr
   Set rngDel(0) = Application.Union(rngDel(0), rngDel(lngZ))
  Next lngZ
 End If
 lngDup = rngDel(0).Cells.Count / 256
 Application.Intersect(rngSel, rngDel(0)).Select
 Application.ScreenUpdating = True
 If MsgBox("Es wurden " & lngDup & " Duplikate im Bereich" & vbLf & _
  strSuchbereich & vbLf & _
  "gefunden." & vbLf & vbLf & "Sollen sie jetzt gelöscht werden?", _
  vbQuestion Or vbYesNo Or vbDefaultButton2) = vbYes Then
  Application.ScreenUpdating = False
  For lngZ = lngArr To 1 Step -1
   rngDel(lngZ).Delete
  Next lngZ
  rngSel.Select
  Application.ScreenUpdating = True
 End If
 FehlerBehandlung:
 Select Case Err.Number
  Case 457
   If rngDel(lngArr) Is Nothing Then
    Set rngDel(lngArr) = Rows(lngZeile + lngAbZeile - 1)
   Else
    Set rngDel(lngArr) = _
    Application.Union(rngDel(lngArr), Rows(lngZeile + lngAbZeile - 1))
   End If
   If rngDel(lngArr).Areas.Count = lngMaxArrays Then
    lngArr = lngArr + 1
    ReDim Preserve rngDel(lngArr)
   End If
   Resume Next
  Case 13, 91
   MsgBox "Im Bereich" & vbLf & vbLf & """" & _
   strSuchbereich & """" & vbLf & vbLf & "gibt es keine Duplikate."
  Case Is > 0
   MsgBox "Fehlernummer: " & Err.Number & vbLf & vbLf & _
   "Felerbeschreibung: " & Err.Description
   'für Entwicklung zum Testen
   '      Application.Calculation = lngCalc
   '      On Error GoTo 0
   '      Resume
 End Select
 Application.Calculation = lngCalc
End Sub