AW: Doppelte Zeilen Komplett löschen
18.06.2007 14:49:00
Hajo_Zi
Hallo Steffen,
das Problem hatte wir gerade vor kurzem, es gibt auch eine Suche im Forum.
Option Explicit
Sub KeineDoppelten_Problem3()
' erstellt von Hajo.Ziplies@web.deb 10.08.03
' neue Tabelle anlegen, Sortieren und alle Doppelten löschen
' Anzahl der doppelten eintragen
Dim LoAnzahl As Long ' Anzahl der Doppelten
Dim LoI As Long ' Schleifenvariablen außen
Dim LoJ As Long ' Schleifenvariable innen
Dim ByAnzahl As Byte
Application.ScreenUpdating = False ' Bildschirmanzeige aus
' alte Tabelle Neu löschen und neue tabelle "Neu" mit Inhalt von Tabelle 1
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Neu").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets("Tabelle1").Copy Before:=Worksheets(1)
ActiveSheet.Name = "Neu"
' Sortieren der Daten nach Spalte A ohne Übeschrift
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1"), Order1:= _
xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' doppelte löschen
LoAnzahl = 1
For LoI = Cells(Rows.Count, 6).End(xlUp).Row - 1 To 1 Step -1
ByAnzahl = 0
For LoJ = 1 To 8
If Trim(Cells(LoI, LoJ)) = Trim(Cells(LoI + 1, LoJ)) Then
ByAnzahl = ByAnzahl + 1
End If
Next LoJ
If ByAnzahl = 8 Then
LoAnzahl = LoAnzahl + 1
Rows(LoI).Delete
Else
' Cells(LoI + 1, 10) = LoAnzahl
If LoAnzahl > 1 Then Rows(LoI + 1).Delete
LoAnzahl = 1
End If
Next LoI
' Cells(1, 10) = LoAnzahl
If LoAnzahl > 1 Then Rows(1).Delete
Application.ScreenUpdating = True ' Bildschirmanzeige ein
Application.CutCopyMode = False ' Zwischenspeicher löschen
End Sub