"Die delete-methode des Range-Objektes
12.01.2023 07:48:39
Anwender
bin sehr neu in dem Gebiet und bin schon seit 2 Wochen an dem Fehler dran, komme nichtmehr weiter.
Habe hier einen Code gefunden der mir das Löschen der Duplikate in einer Spalte ermöglicht.
Bekomme aber manchmal den Fehler "Die delete-methode des Range-Objektes konnte nicht ausgeführt werden"
Vielleicht kann mir von euch jemand helfen. Danke im Voraus!
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 / 13834
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