Problem mit dem Entfernen von Duplikaten

Duplikaten · 2019-05-06T20:45:14+00:00

Hallo, ich hoffe jemand hat eine Lösung für mich, ich möchte mit den Kriterien Spalte A und B Duplikate entfernen aber ich möchte, das alle Zeilen die einen Inhalt in Spalte C haben erhalten bleiben, selbst wenn sie ein Duplikat sind. Oder anders gesagt es sollen nur Duplikate entfernt werden, wenn in der betroffenen Zeile nichts in Spalte C steht. Gibt es da eine Lösung? Danke Jenny

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

Hallo,
nochmal ein bisschen überarbeitet:
VG, C.

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

Problem mit dem Entfernen von Duplikaten

Forumthread: Problem mit dem Entfernen von Duplikaten

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Problem mit dem Entfernen von Duplikaten

Forumthread: Problem mit dem Entfernen von Duplikaten

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread