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.

Please also mark the comments that contributed to the solution of the article

Content-Key: 434628

Url: https://administrator.de/contentid/434628

Printed on: April 18, 2024 at 14:04 o'clock

6 Comments

Latest comment

Hi,
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 Sub

Gruß freesolo

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.

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?

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:

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

Schönes Wochenende noch.

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?

German solved Question Databases Development

Hotly discussed

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments

End of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment