Problem mit Löschmakro in Excel (VBA)
07.01.2009 15:33:31
Seluaner
Ich habe eine Excel - Datei welche folgenden Aufbau hat:
siehe Datei ! https://www.herber.de/bbs/user/58165.xls
Nun soll folgendes mittels dem untenstehenden Makro geschehen:
- In der Excel - Datei sollen alle doppelten Datensätze gelöscht werden.
Und zwar sollen diese komplett gelöscht werden, wenn wirklich komplett identisch (vergleich der Datensätze über alle Spalten)
(es soll also - falls doppelt oder mehrfach vorhanden komplett gelöscht werden)
In beiligender Excel-Datei würde das bedeuten, dass die Zeile 3 und 4 komplett gelöscht würden, da 100% identisch !
Den untenstehenden Makro - Code (welchen ich übrigens von einem netten Forumanen hier vor einiger Zeit erhalten hatte) möchte ich also
so anpassen, dass er nicht nur die Spalte A auf Mehrfacheinträge überprüft, sondern die kompletten Datensätze (Spalten A bis und mit E)
Doch wie geht das ?
Was muss ich anpassen ?
Lasse ich diesen Code nun über meine Excel-Datei laufen, so löscht er mir alle Datensätze bis auf den letzten in Zeile 9, da er jeweils nur die
Werte in der Spalte A vergleicht.
WER KANN MIR HELFEN ?
Sub Doppel_Loesch()
Dim lngRow As Long, lngLast As Long
Dim intCol As Integer
Dim rngDel As Range
intCol = Selection(1).Column
lngLast = Cells(Rows.Count, intCol).End(xlUp).Row
On Error GoTo ErrExit
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For lngRow = 1 To lngLast
If Application.CountIf(Columns(intCol), Cells(lngRow, intCol)) > 1 Then
If rngDel Is Nothing Then
Set rngDel = Rows(lngRow)
Else
Set rngDel = Union(rngDel, Rows(lngRow))
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
ErrExit:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A2").Select
Windows("Daten_Import Aufteiler.xls").Activate
Sheets("Tabelle1").Select
MsgBox "DATEN ERFOLGREICH IN NEUER ARBEITSMAPPE AUFBEREITET", vbInformation, "Programm-Ende"
End Sub