Listeleme

[polis-53]

Ekte göndermiş olduğum tablodaki listede görmüş olduğunuz gibi her bir isme ait birden fazla kayıt var.
Ben bu listedeki her isme ait, tarih sıralamasına göre son kaydı süzmek istiyorum

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub SonListele()
Set sv = Sheets("vardiya")
Set sl = Sheets("Liste")
Dim i As Long
i = [A65536].End(3).Row
sl.Cells.ClearContents
sv.Range("A1:G" & i).Copy sl.[A1]
sl.Select
Application.ScreenUpdating = False
Range("A2:G" & i).Sort Key1:=[A2], Order1:=xlAscending, Key2:=[G2], Order2:=xlDescending
For i = i To 3 Step -1
    If Cells(i, "A") = Cells(i - 1, "A") Then Rows(i).Delete
Next i
 
End Sub

 

[polis-53]

teşekkürler

Allah razı olun

 

[Tarkan VURAL]

Alternatif olsun

Sub SonTarihleriFiltreEt()
On Local Error Resume Next
    Dim evn As Worksheet
        Set evn = Worksheets("vardiya")

evn.Cells.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
    , Order2:=xlAscending, Key3:=Range("G2"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                xlSortNormal
    
    Sheets("Rapor").Select
        If Err.Number = 9 Then Sheets.Add.Name = "Rapor"
            Err.Clear
        
    With Sheets("Rapor")
        .Range("a1").Value = "Adı Soyadı"
            .Range("b1").Value = "Hafta Tatil"
                .Range("c1").Value = "Vardiya Kodu"
                    .Range("d1").Value = "Tarih"
                
For i = 2 To evn.Range("b65536").End(3).Row
    If evn.Cells(i, 2).Value & evn.Cells(i, 3).Value <> _
        evn.Cells(i + 1, 2).Value & evn.Cells(i + 1, 3).Value Then
            .Range("a65536").End(3)(2, 1).Value = evn.Cells(i, 2).Value & " " & evn.Cells(i, 3).Value
                .Range("a65536").End(3)(1, 2).Value = evn.Cells(i, 5).Value
                    .Range("a65536").End(3)(1, 3).Value = evn.Cells(i, 6).Value
                        .Range("a65536").End(3)(1, 4).Value = evn.Cells(i, 7).Value
    End If
Next i
    .Columns.AutoFit
    End With
        Set evn = Nothing
            i = Empty
End Sub