AW: Doppelte Datensätze komplett löschen
15.04.2009 12:53:22
Tino
Hallo,
hier meine Version.
Bin erst heute Abend wieder Online.
Option Explicit
Sub Loesche_Doppelte()
Dim Bereich As Range
Dim LRow As Long
Dim iCalc As Integer
With Application
.ScreenUpdating = False
iCalc = .Calculation
.Calculation = xlCalculationManual
With Sheets("Artikelnummern")
LRow = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With Sheets("DatenKopie")
Set Bereich = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
Set Bereich = Bereich.Offset(0, .Columns.Count - 2)
Bereich.Offset(0, -1).FormulaR1C1 = "=ROW()"
Bereich.FormulaR1C1 = "=IF(COUNTIF(Artikelnummern!R1C2:R" & LRow & "C2,RC2)>0,0,"""")"
.Cells.Sort .Cells(1, .Columns.Count), xlAscending, , , , , , xlNo
If Application.WorksheetFunction.CountIf(Bereich, 0) > 0 Then
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End If
.Cells.Sort .Cells(1, .Columns.Count - 1), xlAscending, , , , , , xlNo
.Columns(.Columns.Count).Delete
.Columns(.Columns.Count - 1).Delete
End With
.ScreenUpdating = True
.Calculation = iCalc
End With
End Sub
Gruß Tino