6
Excel - Duplikate vergleichen und entfernen
Hallo Community,
ich bin auf der Suche nach einer Lösung für angehängtes Bild.
Hierbei sind Duplikate ZEILE 2 & 3
ZEILE 9 & 10
ZEILE 27 & 28
vorhanden.
Es soll der Wert in Spalte "I" mit dem dazugehörigen Duplikate verglichen werden. Die Zeile mit dem niedrigeren Wert aus Spalte "I" soll entfernt werden.
Hat jemand nen Lösungsvorschlag? Gerne auch einen VBA Code
Für Eure Mühe, vielen Dank im voraus.
ich bin auf der Suche nach einer Lösung für angehängtes Bild.
Hierbei sind Duplikate ZEILE 2 & 3
ZEILE 9 & 10
ZEILE 27 & 28
vorhanden.
Es soll der Wert in Spalte "I" mit dem dazugehörigen Duplikate verglichen werden. Die Zeile mit dem niedrigeren Wert aus Spalte "I" soll entfernt werden.
Hat jemand nen Lösungsvorschlag? Gerne auch einen VBA Code
Für Eure Mühe, vielen Dank im voraus.
Auf Facebook teilen
Auf Twitter teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 434628
Url: https://administrator.de/contentid/434628
Ausgedruckt am: 16.11.2024 um 03:11 Uhr
6 Kommentare
Neuester Kommentar
Hi,
sind es immer maximal 2 Duplikate und stehen diese immer direkt untereinander?
In dem Fall:
Gruß freesolo
sind es immer maximal 2 Duplikate und stehen diese immer direkt untereinander?
In dem Fall:
Sub KleinstesDuplikatEntfernen()
Dim rCell As Range, rDel As Range, rDup As Range, lineCurrent as String, lineNext as String
With ActiveSheet
Set rCell = .Range("A2")
While rCell <> ""
lineCurrent = rCell.Value & rCell.Offset(0, 1).Value & rCell.Offset(0, 2)
lineNext = rCell.Offset(1, 0).Value & rCell.Offset(1, 1).Value & rCell.Offset(1, 2)
If lineCurrent = lineNext Then
Set rDup = IIf(rCell.Offset(0, 3).Value <= rCell.Offset(1, 3).Value, rCell.EntireRow, rCell.Offset(1, 0).EntireRow)
If Not rDel Is Nothing Then
Set rDel = Union(rDel, rDup)
Else
Set rDel = rDup
End If
End If
Set rCell = rCell.Offset(1, 0)
Wend
If Not rDel Is Nothing Then
rDel.Delete
End If
End With
End SubGruß freesolo
1
Hi freesolo,
innerhalb der Personalnummer stehen Sie leider nicht untereinander. es können bis zu mehr als 2 Duplikate vorkommen. Mehr als 3 habe ich noch nicht gesehen.
innerhalb der Personalnummer stehen Sie leider nicht untereinander. es können bis zu mehr als 2 Duplikate vorkommen. Mehr als 3 habe ich noch nicht gesehen.
Zitat von @CaptnHowdy:
Hi freesolo,
innerhalb der Personalnummer stehen Sie leider nicht untereinander. es können bis zu mehr als 2 Duplikate vorkommen. Mehr als 3 habe ich noch nicht gesehen.
Und du willst nur die Zeile löschen die am geringsten ist. Was soll dann deiner Meinung nach geschehen wenn es mehr wie 2 sind? Die Zeile mit dem größten Wert stehen lassen und alle anderen löschen oder was?Hi freesolo,
innerhalb der Personalnummer stehen Sie leider nicht untereinander. es können bis zu mehr als 2 Duplikate vorkommen. Mehr als 3 habe ich noch nicht gesehen.
1
korrekt. Sorry wenn ich mich hier nicht klar ausgedrückt habe, und die Ausnahmen nicht bedacht habe. Ich könnte aber die Datei aufbereiten und die einzelnen Felder verketten, und diese dann sortieren. Ich denke da komm ich auch gut zum Ziel damit. Genial, danke für deine erneute Hilfe!
OK, in dem Fall kannst du hiermit arbeiten wenn du es noch gebrauchen kannst, Anzahl Duplikate ist egal lässt immer nur den mit dem größten Wert in Spalte D übrig:
Schönes Wochenende noch.
Sub DuplikateEntfernen()
Dim rDel As Range, lngLastRow As Long, lineCurrent As String, lineNext As String, cnt As Integer, cell As Range
With ActiveSheet
lngLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
With .Sort
.SortFields.Clear
.SetRange ActiveSheet.Range("A1:D" & lngLastRow)
.Header = xlYes
.SortFields.Add Key:=ActiveSheet.Range("A2:A" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=ActiveSheet.Range("B2:B" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=ActiveSheet.Range("C2:C" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=ActiveSheet.Range("D2:D" & lngLastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Apply
End With
For Each cell In .Range("A2:A" & lngLastRow)
lineCurrent = cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 2)
lineNext = cell.Offset(1, 0).Value & cell.Offset(1, 1).Value & cell.Offset(1, 2)
cnt = 1
While lineCurrent = lineNext
If Not rDel Is Nothing Then
Set rDel = Union(rDel, cell.Offset(cnt, 0).EntireRow)
Else
Set rDel = cell.Offset(cnt, 0).EntireRow
End If
cnt = cnt + 1
lineNext = cell.Offset(cnt, 0).Value & cell.Offset(cnt, 1).Value & cell.Offset(cnt, 2)
Wend
Next
If Not rDel Is Nothing Then
rDel.Delete
End If
End With
End Sub
Wow, das ist ja ne Meisterarbeit. Ich werde es morgen direkt testen und gebe dir bescheid . Ich sag schon mal tausend Dank für deine Mühe. Schaut schon heftig aus. Da hast Du sicherlich viel Zeit investiert.
Nachtrag: Das Makro läuft gerade. Wird hier nur das aktive Tablellenblatt bearbeitet oder die ganze Mappe?
Nachtrag: Das Makro läuft gerade. Wird hier nur das aktive Tablellenblatt bearbeitet oder die ganze Mappe?
