Duplikate anzeigen/löschen
21.11.2014 15:59:37
ToS2
Bin absoluter VBA-Neuling.
Hab einen netten Code gefunden mit dem man Duplikate finden kann.
Jetzt möcht ich doch gern dass dieser Code so umgebastelt wird dass er automatisch
die Zeile 2 Spalte A:I als Referenz nimmt
und in den Zeile 10 bis zum Ende der Liste (ca.1000 Zeilen) Spalten A:I auf Duplikate sucht (jeder Wert muss übereinstimmen).
Die Code sollte mit CommandButton2_Click() gestartet werden.
Hat jemand eine Lösung?
Es muss auch nicht dieser Code benutzt werden, entspricht aber meinen Wünschen:
Anzeige des Bereichs der Dupletten
Markierung
Frage ob gelöscht werden soll...
SG
ToS2
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 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
