Problem mit dem Entfernen von Duplikaten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HI
da fällt mir spontan nur folgende Lösung ein:
1. falls in den Echtdaten nicht vorhanden: füge eine Überschriftenzeile ein, die zu bearbeitenden Daten dürfen nicht in Zeile 1 beginnen, sondern frühestens ab Zeile 2
2. sortiere die Liste nach Spalte A, B und C, so dass Duplikate direkt untereinander stehen und die Zeile, die in C einen Wert haben, zuerst kommen (Leerzellen sortiert Excel nach unten)
3. füge dann in Zelle D2 diese Formel ein und kopiere sie nach unten:

=WENN(C2"";ZEILE();WENN(UND(A2=A1;B2=B1);0;ZEILE()))

4. schreibe in die Zelle D1 (Überschrift der Hilfsspalte) die 0
5. führe jetzt mit den Spalten A-D die Funktion DATEN - DATENTOOLS - DUPLIKATE ENTFERNEN aus, mit der Spalte D als Kriterium und der Option "keine Überschrift"
6. lösche die Hilfsspalte wieder
Gruß Daniel

Hi,
mal in deiner Beispieldatei ausprobieren
VG, Christian

Option Explicit
Public Function getRange(ByRef ws As Worksheet, ByRef StartZelle As String) As Range
Set getRange = ws.Range(StartZelle).CurrentRegion.Offset(1).Resize(ws.Range(StartZelle). _
CurrentRegion.Rows.Count - 1)
End Function
Sub DuplikateEliminieren()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle1")
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim coll As Collection
Set coll = New Collection
' Datenbereich wie im Beispiel nur wird angenommen dass in Zeile 1 eine Überschrift  _
steht
Dim rng As Range
Set rng = getRange(ws, ws.Cells(1, 1).Address)
Dim r As Variant
Dim arr(2) As Variant
For Each r In rng.Rows
Dim key As String
key = r.Cells(1, 1).Value & r.Cells(1, 2).Value
If Not r.Cells(1, 3).Value = "" Then
arr(0) = r.Cells(1, 1).Value
arr(1) = r.Cells(1, 2).Value
arr(2) = r.Cells(1, 3).Value
dict.Add r.Row, arr
End If
If Not dict.exists(key) Then
arr(0) = r.Cells(1, 1).Value
arr(1) = r.Cells(1, 2).Value
arr(2) = ""
dict.Add key, arr
End If
Next r
' Ausgabe in Spalte E (i + 5)
Dim e As Variant
' Erste Ausgabezeile
Dim zeile As Long
zeile = 2
For Each e In dict.items
Dim i As Long
For i = 0 To UBound(e)
ws.Cells(zeile, i + 5).Value = e(i)
Next i
zeile = zeile + 1
Next e
End Sub

Option Explicit Public Function getRange(ByRef ws As Worksheet, ByRef StartZelle As String) As Range Set getRange = ws.Range(StartZelle).CurrentRegion.Offset(1).Resize(ws.Range(StartZelle). _ CurrentRegion.Rows.Count - 1) End Function Sub DuplikateEliminieren() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Tabelle1") Dim dict As Object Set dict = CreateObject("scripting.dictionary") ' Datenbereich wie im Beispiel nur wird angenommen dass in Zeile 1 eine Überschrift _ steht Dim rng As Range Set rng = getRange(ws, ws.Cells(1, 1).Address) Dim r As Variant Dim arr(2) As Variant For Each r In rng.Rows Dim key As String key = r.Cells(1, 1).Value & r.Cells(1, 2).Value If Not dict.exists(key) Then arr(0) = r.Cells(1, 1).Value arr(1) = r.Cells(1, 2).Value arr(2) = r.Cells(1, 3).Value dict.Add key, arr Else If Not r.Cells(1, 3).Value = "" Then arr(0) = r.Cells(1, 1).Value arr(1) = r.Cells(1, 2).Value arr(2) = r.Cells(1, 3).Value dict.Add r.Row, arr End If End If Next r ' Ausgabe in Spalte E (i + 5) Dim e As Variant ' Erste Ausgabezeile Dim zeile As Long zeile = 2 For Each e In dict.items Debug.Print VarPtr(e) Dim i As Long For i = 0 To UBound(e) ws.Cells(zeile, i + 5).Value = e(i) Next i zeile = zeile + 1 Next e End Sub

Beliebteste Forumthreads (12 Monate)

Problem mit dem Entfernen von Duplikaten

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Problem mit dem Entfernen von Duplikaten

28 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread