AW: doppelte löschen (Original und Duplikat)
22.06.2009 12:57:57
fcs
Hallo Tom,
geht etwa so, wenn du eine Spalte nach doppelten Werten durchsuchen möchtest.
Gruß
Franz
Sub DoppelteKomplettLoeschen()
Dim wks As Worksheet, lngSpalteMark As Long
Dim lngZeile As Long, lngZeileLast As Long, SpalteSuch As Long
SpalteSuch = 1 'nach doppelten Werten zu durchsuchende Spalte
Set wks = ActiveSheet
With wks
lngSpalteMark = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1
lngZeileLast = .Cells(.Rows.Count, SpalteSuch).End(xlUp).Row
'Zu löschende Zeilen markieren
Application.ScreenUpdating = False
For lngZeile = 1 To lngZeileLast
If Application.WorksheetFunction.CountIf(.Range(.Cells(1, SpalteSuch), _
.Cells(lngZeileLast, SpalteSuch)), .Cells(lngZeile, SpalteSuch).Value) > 1 Then
.Cells(lngZeile, lngSpalteMark) = "X"
End If
Next
'Zeilen mit Markierung löschen
If Application.WorksheetFunction.CountIf(.Range(.Cells(1, lngSpalteMark), _
.Cells(lngZeileLast, lngSpalteMark)), "X") > 1 Then
.Columns(lngSpalteMark).SpecialCells(xlCellTypeConstants).EntireRow.Delete
End If
Application.ScreenUpdating = True
End With
End Sub