Doppelter Eintrag löschen funktioniert nicht

Sub Doppelte_Artikel_Einträge_löschen() ' Doppelte_Einträge_löschen Makro ''Abfragebox für sicheres übernehmen Dim lngZeile As Long, Loletzte& Dim strQuest As String strQuest = MsgBox(" doppelte Einträge löschen....sicher? ", vbYesNo + vbQuestion, "") If strQuest = vbNo Then Exit Sub Loletzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) ' ab Zeile löschen- hier 100 For lngZeile = Loletzte To 100 Step -1 If lngZeile > 100 Then If Application.CountIf(Columns(1), Cells(lngZeile, 1)) > 1 Then Rows(lngZeile).Delete End If Else Exit For End If Next lngZeile End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Andreas,
wahrscheinlich laufen in deiner Tabelle Formeln mit umfangreichen Berechnungen oder Makros. die automatisch bei Zellwertänderungen starten.
Damit das Makro schneller läuft solltest du im Makro vor Beginn der Löschaktionen die Bildschirmaktualisierung und Ereignismakros deaktivieren und die Berechnung auf "manuell" setzen.
Danach dann wieder aktivieren bzw. auf "automatisch" setzen.
Ich empfehle die folgende Variante des Makros. Sie ist deutlich schneller in der Ausführung.
Gruß
Franz

Sub Doppelte_Artikel_Einträge_löschen_2()
' Doppelte_Einträge_löschen Makro
''Abfragebox für sicheres übernehmen
Dim lngZeile As Long, Loletzte&, wks As Worksheet, rngZelle As Range, bolLoeschen As Boolean
Dim strQuest As String
strQuest = MsgBox("       doppelte Einträge löschen....sicher?  ", vbYesNo + vbQuestion, "")
If strQuest = vbNo Then Exit Sub
Set wks = ActiveSheet
With wks
Set rngZelle = .Cells.Find(what:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
MsgBox "Keine Daten im Tabellenblatt"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Loletzte = rngZelle.Row
Const ZeileStart As Long = 100 '  ab Zeile  löschen- hier 100
For lngZeile = ZeileStart To Loletzte
If Application.CountIf(.Range(.Cells(1, 1), .Cells(lngZeile, 1)), _
.Cells(lngZeile, 1)) > 1 Then
.Cells(lngZeile, 1).ClearContents
bolLoeschen = True
End If
Next lngZeile
If bolLoeschen = True Then
With .Range(.Cells(ZeileStart, 1), .Cells(Loletzte, 1))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End If
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End If
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Doppelter Eintrag löschen funktioniert nicht

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelter Eintrag löschen funktioniert nicht

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread