Folgendes Problem:
Ich ziehe aus einem Worksheet Daten in eine Listbox (ca 100 Spalten und max 500 Zeilen).
Das rausziehen funktioniert folgendermassen:
A B C
7 1
8 1
5
3 1 1
6 1
In Spalte A steht eine einmalige Seriennummer (Primaerschluessel). Gesucht wird in den Spalten B und C.
Falls die jeweilige Zelle "" ist, dann wird der komplette Datensatz ausgelesen und auf ein Worksheet zwischengespeichert und dann in die ListBox geschrieben. Nach obigen Beispiel sieht man also Datensatz 7, 8, 3, 3 und 6 in der Listbox.
Nun moechte ich, dass schon beim Einlesen Duplikate vermieden werden, oder nach Betaetigen eines Buttons die Duplikate loeschen. Ich habe dazu eine Methode verwendet. Es funktioniert auch alles, Problem ist nur, dass ich immer den letzten Datensatz geloescht bekomme, ob Duplikate vorhanden sind oder nicht. Also auch in obigem Beispiel wuerden nur noch die Datensaetze 7,8 und 3 angezeigt werden.
Hier die Methode:
Sub DoppelteLoeschen()
Call Loeschen
End Sub
Sub Loeschen()
Dim Suchen As Integer
Dim Weiter As Integer
Dim EndFind As Integer
Dim i As Integer
Range("A1").Select
EndFind = ActiveSheet.Cells(65536, 1).End(xlUp).Row
For i = 1 To EndFind
Daten = Cells(i, 1).Value
For Each d In Range(Cells(i + 1, 1), Cells(EndFind, 1))
If Daten = d Then
Zelle = d.Row
Rows(Zelle & ":" & Zelle).Select
Selection.Delete Shift:=xlUp
EndFind = EndFind + 1
End If
If EndFind
Next d
Next i
End Sub
Private Sub CheckBox3_Click()
Call ZeilenMitDublikatenLoeschen
End Sub
Sub ZeilenMitDublikatenLoeschen()
Dim Zelle As Range, i As Integer, j As Integer, Loeschstr As String
Zeit = Timer
Set DicOriginal = CreateObject("scripting.dictionary")
i = Range("A65536").End(xlUp).Row
Call EventsOff
For j = i To 2 Step -1
If DicOriginal.Exists(Cells(j, 1).Value) = False Then
DicOriginal.Add Cells(j, 1).Value, Cells(j, 1).Address(0, 0)
Else
Loeschstr = Loeschstr & Cells(j, 1).Row & ":" & Cells(j, 1).Row & ","
If Len(Loeschstr) > 244 Then
Loeschstr = Left(Loeschstr, Len(Loeschstr) - 1)
Range(Loeschstr).Delete
Loeschstr = ""
End If
End If
Next j
If Len(Loeschstr) > 0 Then
Loeschstr = Left(Loeschstr, Len(Loeschstr) - 1)
Range(Loeschstr).Delete
End If
Debug.Print Round(Timer - Zeit, 1) & " Sekunden"
Call EventsOn
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Ich hoffe ihr koennt mir helfen!!!
Vielen Dank