Doppelte Einträge nach Datum löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

hab mir jetzt mal selber was gebastelt. das funzt auch...


Private Sub CommandButton1_Click()
Dim reihe As Long
Dim i As Long
'-Letze beschriebene Zeile in Spalte A finden
i = 3
Do
If ActiveSheet.Cells(i, 1) <> "" Then
i = i + 1
End If
Loop Until ActiveSheet.Cells(i, 1) = ""
i = i - 1
'-Erst nach Namen, dann nach Zugriff Sortieren. Letzter Zugriff oben
Range(Cells(1, 1), Cells(i, 2)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
'- Überprüft, ob sich in Spalte A zwei gleiche Namen befinden. Der ältere Eintrag wird
'- gelöscht
reihe = 1
Do
If Cells(reihe, 1) = Cells(reihe + 1, 1) Then
If Cells(reihe, 2) >= Cells(reihe + 1, 2) Then
Rows(reihe + 1).Select
Selection.Delete Shift:=xlUp
End If
End If
reihe = reihe + 1
Loop Until Cells(reihe, 1) = ""
'- Nach Zugriffsdatum sortieren. Letzer Zugriff oben
Range(Cells(1, 1), Cells(i, 2)).Select
Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub

Sub DeleteDouble() Columns("A:B").Sort Key1:=Range("A2"), _ Order1:=xlAscending, Key2:=Range("B2"), _ Order2:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("A3").Select While Len(ActiveCell.Value) > 0 If ActiveCell = ActiveCell.Offset(-1, 0) Then Rows(ActiveCell.Row).Delete Shift:=xlUp Else ActiveCell.Offset(1, 0).Select End If Wend End Sub

Hallo
Gestern war was ähnliches hier:
http://www.office-loesung.de/ftopic91742_0_0_asc.php
Angepasst auf deine Verhältnisse tut es dann dieser code:

Option Explicit
Public Sub test()
    Dim arrNum As Variant
    Dim arrDat
    Dim arrges(65536, 2) As Variant
    Dim Letzte As Long
    Dim bereich As Range
    Dim zelle As Range
    Dim L As Long
    Dim Z As Long
    Dim T As Long
    Dim Datum As Date
    Dim Blatt As Worksheet
Set Blatt = Worksheets("Tabelle1") 'Anpassen
Letzte = Blatt.Range("A65536").End(xlUp).Row
Set bereich = Blatt.Range("A2:A" & Letzte)
arrNum = Blatt.Range("A2:A" & Letzte).Value
arrDat = Blatt.Range("B2:B" & Letzte).Value
arrges(L, 0) = "Name"
arrges(L, 1) = "Datum"
L = L + 1
For Each zelle In bereich
    If WorksheetFunction.CountIf(bereich, zelle.Value) > 1 Then
        If WorksheetFunction.CountIf(Blatt.Range("a2:A" & zelle.Row), zelle.Value) = _
        WorksheetFunction.CountIf(bereich, zelle.Value) Then
            arrges(L, 0) = zelle
            L = L + 1
        End If
    End If
Next
For Z = 1 To L
Datum = 1
    For T = 1 To UBound(arrNum)
        If arrges(Z, 0) = arrNum(T, 1) Then
            If Datum < arrDat(T, 1) Then
                Datum = arrDat(T, 1)
                arrges(Z, 1) = Format(Datum, "DD.MM.YY")
            End If
        End If
    Next
Next
Sheets("Tabelle2").Range("A:B") = arrges 'Anpassen
End Sub

ransi

Beliebteste Forumthreads (12 Monate)

Doppelte Einträge nach Datum löschen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

103 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Doppelte Einträge nach Datum löschen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

103 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread