Option explicit

Sub DoppelteEintraegeLoeschen()
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Dim colUnique As New Collection
  Dim lngAbZeile&
  Dim lngArr&
  Dim lngC&
  Dim lngCalc&
  Dim lngDup&
  Dim lngMaxArrays&
  Dim lngZ&
  Dim lngZeile&
  Dim lngZeilenArray&
  Dim lngZeilenBereich&
  Dim rngArea As Range
  Dim rngAuswahl As Range
  Dim rngC As Range
  Dim rngDel() As Range
  Dim rngSel As Range
  Dim strSuchbereich$
  Dim strZeile$
  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", 1, , , , , 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, ""
  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
  End Select
  Application.Calculation = lngCalc
  Application.DisplayAlerts = True
  Application.EnableEvents = True
End Sub