Hallo,
ich habe ein kleines Problem und es wäre super wenn mir da jemand von euch helfen könnte da ich in VBA nicht sehr bewandert bin.
Ich habe eine riesige Excel Datenbank mit Duplikaten(und ganz wenigen nicht-Duplikaten) und ein VBA Script das mir hilft diese zu löschen. Funktioniert auch super...
ABER ich muss auch die dazugehörigen originale löschen. Soll heissen:
Jedes Original das ein Duplikat hat->Original löschen und Duplikat.
Kann mir jemand helfen wo ich das script umschreiben muss oder ist das zu viel arbeit? Wäre einfach nur sehr praktisch für mich...
Greetz
Christine
Sub DoppelteEintraegeLoeschen()
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
End Select
Application.Calculation = lngCalc
End Sub
|