Bulunan Değere Karşılık Gelen Birden Çok Veriyi Listeleme

[ceyhun01]

Merhaba değerli arkadaşlar,
Ekte gönderdiğim liste isimli dosyada bulunan verilere ilişkin başlıkta belirttiğim şekilde listeleme yapmak istiyorum. Dosya içesinde ne yapmak istediğime dair bir not mevcut. Bu konuda yardımcı olabilirseniz sevinirim.

 

[Asri]

Dosyada Rapor adında bir sayfa olmalı.

Sub Rapor()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets("Rapor").Select
    Cells.ClearContents
    Sheets("Sayfa1").Cells.Copy
    Sheets("Rapor").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B3").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
      If Cells(1, 1).Value <> "" Then Exit For
      Rows(1).Delete
    Next i
    
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("B:B").Select
    Selection.Cut
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
    Range("B8").Select
    
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "ADI SOYADI"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "TARİH"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "SÜRE"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "TİP"
    Range("D2").Select
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

 

[ceyhun01]

Teşekkür ederim sayın asri. Kusursuz çalışıyor.

 

[Ömer BARAN]

Merhaba.

Alternatif. (Rapor adlı sayfaya listeler ve isme göre alfabetik, tarihe göre artan sıralar)
.

[B]Sub LISTE()[/B]
Set s1 = Sheets("Sayfa1"): Set r = Sheets("[B][COLOR="Blue"]Rapor[/COLOR][/B]")
son = s1.Cells(Rows.Count, 1).End(3).Row
ilk = s1.[A1].End(xlDown).Row
    r.Range("A1:D" & r.Cells(Rows.Count, 1).End(3).Row).ClearContents
    s1.Range("G" & ilk & ":G" & son).Copy r.[A1]
    s1.Range("E" & ilk & ":F" & son).Copy r.[B1]
    s1.Range("C" & ilk & ":C" & son).Copy r.[D1]
    r.[A1] = "ADI SOYADI"
r.Range("A2:D" & son - ilk + 1).Sort Key1:=r.[A2], Order1:=1, Key2:=r.[B2], Order2:=1
[COLOR="Red"]For sat = son - ilk + 1 To 3 Step -1
    If r.Cells(sat - 1, 1) <> "" And r.Cells(sat, 1) <> r.Cells(sat - 1, 1) Then _
       Range("A" & sat & ":D" & sat).Insert Shift:=xlDown
Next[/COLOR]
[B]End Sub[/B]

 

[Ömer BARAN]

Tekrar merhaba.

Eğer sıralanmış halinde, her isim değiştiğinde bir boş satır oluşmasını da istiyorsanız;
önceki cevabıma ekleyip kırmızı renklendirdiğim kısımı ekleyerek kullanırsınız.

Sayfayı yenileyerek önceki cevabımı kontrol edin.
.