2 Spalten auf Duplikate prüfen und koppieren

Hallo Zusammen;
das Forum konnte mir schon häufiger bei Problemen helfen, die ich über Google gesucht habe, leider finde ich nicht das passende für mein derzeitiges Problem und daher jetzt mal direkt ins Forum.
Ich soll eine Datei erstellen zum Abgleich zweier Datensätze mit alphanumerischen Codes. Hierzu habe ich, wie in der Beispieldatei zu sehen eine Mappe erstellt, die per SVERWEIS einen Abgleichdurchführt. Nur leider sollen doppelte Elemente nur einmal aus der Eingabetabelle gezogen werden.
Der Spezialfilter ist leider unbrauchbar, weil die Datei hinterher Leute benutzen, die wenig bis keine Ahnung haben von Excel. Daher wäre eine automatisierte Lösung per VBA wünschenswert.
Es soll also eine Prüfung der Spalte A auf Tabellenblatt "Eingabetabelle" auf Duplikate gemacht werden und dann der Datensatz ohne Duplikate auf das Tabellenblatt "Auswertung" kopiert werden. Das gleiche soll auch mit der Spalte D passieren.
Ich habe schon das ein oder andere gefunden, das meinem Problem nahe kommt, aber dann ist es nur eine Spalte, oder es werden nur die Duplikate ausgegeben. Und mein Verständnis für VBA ist eher bescheiden bis nicht nicht vorhanden.
Beispieldatei:
https://www.herber.de/bbs/user/126096.xlsm
Ich hoffe ich habe nichts vergessen und dass ihr mir helfen könnt.
Danke im Voraus für Eure Unterstützung.
Grüße,
Martin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub F_en() Dim A As Object Dim D As Object Set A = CreateObject("Scripting.Dictionary") Set D = CreateObject("Scripting.Dictionary") With Sheets("Auswertung") 'Laden der bereits bearbeiteten Codes 'Spalte A lr = .Cells(Rows.Count, 1).End(xlUp).Row If lr > 1 Then For i = 2 To lr A.Item(.Cells(i, 1).Value) = vbNull Next i End If 'Spalte D lr = .Cells(Rows.Count, 4).End(xlUp).Row If lr > 1 Then For i = 2 To lr D.Item(.Cells(i, 4).Value) = vbNull Next i End If End With 'Auswertung With Sheets("Eingabetabelle") lr = .Cells(Rows.Count, 1).End(xlUp).Row If lr > 1 Then For i = 2 To lr If Not A.exists(.Cells(i, 1).Value) Then _ A.Item(.Cells(i, 1).Value) = vbNull Next i End If 'Spalte D lr = .Cells(Rows.Count, 4).End(xlUp).Row If lr > 1 Then For i = 2 To lr If Not D.exists(.Cells(i, 4).Value) Then _ D.Item(.Cells(i, 4).Value) = vbNull Next i End If End With With Sheets("Auswertung") Cells(2, "G").Resize(A.Count) = Application.Transpose(A.keys) Cells(2, "J").Resize(D.Count) = Application.Transpose(D.keys) End With Set A = Nothing Set D = Nothing End Sub

Public Sub ohne_Duplikate() Dim loLetzte As Long Application.ScreenUpdating = False With Worksheets("Eingabetabelle") loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row .Range(.Cells(2, 1), .Cells(loLetzte, 1)).Copy Worksheets("Auswertung").Cells(2, 1) loLetzte = .Cells(.Rows.Count, 4).End(xlUp).Row .Range(.Cells(2, 4), .Cells(loLetzte, 4)).Copy Worksheets("Auswertung").Cells(2, 4) End With With Worksheets("Auswertung") loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row Worksheets("Auswertung").Range("$A$2:$A$" & loLetzte).RemoveDuplicates Columns:=1, Header:= _ xlNo loLetzte = .Cells(.Rows.Count, 4).End(xlUp).Row Worksheets("Auswertung").Range("$D$2:$D$" & loLetzte).RemoveDuplicates Columns:=1, Header:= _ xlNo End With End Sub

Beliebteste Forumthreads (12 Monate)

2 Spalten auf Duplikate prüfen und koppieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2 Spalten auf Duplikate prüfen und koppieren

6 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)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread