Autor: Uwe Küstner  --- Aus Excel VBA - Gruppe: Verschiedenes

Duplikate löschen spezial

Autor: Uwe Küstner - Erstellt: 2006-04      - Letzte Revision: --
Duplikate löschen an gleicher Stelle

- Suchspalten sind frei wählbar
- Formeln bleiben erhalten


Zum Entfernen von Duplikaten ist normalerweise der Spezialfilter die erste Wahl, da er formelfrei und schnell arbeitet.

Aber:
  • er vergleicht alle Spalten des Listenbereichs auf Duplikate. Und nur, wenn alle Spalten übereinstimmen, werden die Dublettenzeilen gelöscht
  • die Liste muss eine Überschriftenzeile haben
  • es funktioniert nur, wenn an eine andere Stelle kopiert wird
  • und falls die Tabelle Formeln enthält, sind sie im Anschluss gelöscht
Mit nachstehendem Code gebe ich Ihnen ein Medium,
  • mit dem Sie alle oder ausgewählte Spalten auf Dubletten untersuchen können
  • mit dem an gleicher Stelle die Daten auf das Gewünschte reduziert werden
  • bei dem es egal ist, ob die Liste eine Überschriftenzeile hat
  • mit dem die Formeln erhalten bleiben
  • das mindestens doppelt so schnell ist wie der Spezialfilter
Zur Handhabung des Codes:
  • Um nach Dubletten in einer Spalte zu suchen, setzen sie den Cursor vor Makroaufruf in diese Spalte
  • Um nach Dubletten in Bezug auf mehrere Spalten zu suchen, markieren Sie diese vor Makroaufruf mit gedrückter Strg-Taste
  • Um nach Dubletten in Bezug auf alle Spalten zu suchen, markieren Sie diese vor Makroaufruf, indem sie alle Spalten des Bereichs markieren
  • Es wird rückgefragt, ab welcher Zeile das Makro arbeiten soll, voreingestellt ist Zeile 2, da angenommen wird, dass in Zeile 1 die Überschrift liegt; aber das können Sie grundsätzlich im Code ändern oder bei Makroablauf aktuell über Inputboxeingabe ändern
  • Vor dem endgültigen Löschen erfolgt eine Mitteilung, wieviel Duplikate gefunden wurden mit der Rückfrage, ob wirklich gelöscht werden soll
  • Wenn Sie bei dieser Rückfrage auf Nein klicken, bricht der Code ab, aber die Dubletten der durchsuchten Spalten bleiben markiert. Sie könnten die Dubletten nun auf Wunsch (vorher nicht woanders hinklicken!!!) umformatieren, wenn Sie diese durch Formatierung kennzeichnen wollen.
 
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



Weitere Artikel der Gruppe: Verschiedenes Aus Excel VBA
Nach oben
ToDo
Google Werbung