OYP Listeleme

[Hakan ERDOST]

Herkese merhaba ekli listede çocukların toplu OGES puanlar var ben bunları ikinci bir sayfada listeleme yapmak istiyorum özellikle OYP puanları lazım ad soyada göre.D39,D47 şeklinde devam eden hücrelerde.Dosya ekte.Kolay gelsin.Dosyada temsili 3 öğrenci bilgisi var ve geçek şahıs değil.Toplam listemde 140 öğrenci var.

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız.

Sub Duzenle()
 
    Dim S1 As Worksheet, i As Long, sAt As Long
    Set S1 = Sheets("Sheet1")
 
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
 
    Cells.Clear
 
    Range("A1") = "Adı Soyadı"
    Range("B1") = "Puanı"
 
    Range("A1:B1").Borders.LineStyle = 1
    Range("A1:B1").Interior.ColorIndex = 36
 
    sAt = 2
    For i = 3 To S1.Cells(Rows.Count, "D").End(xlUp).Row Step 16
        Cells(sAt, "A") = S1.Cells(i, "H")
        Cells(sAt, "B") = S1.Cells(i + 4, "D")
        sAt = sAt + 1
    Next i
 
    Cells.EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Huseyinkis]

ekteki kodları denermisiniz. (Alternatif)

Sub Deneme()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sayfa1")
For i = 1 To Range("D65536").End(3).Row
If Cells(i, 4).Value = "T.C. Kimlik No" Then
snst = s2.Range("A65536").End(3).Row + 1
s2.Cells(snst, 1).Value = s1.Cells(i + 1, 8).Value
s2.Cells(snst, 2).Value = s1.Cells(i + 12, 4).Value
s2.Cells(snst, 3).Value = s1.Cells(i + 13, 4).Value
End If
Next
End Sub

 

[Hakan ERDOST]

İlginiz için Teşekkürler.Kolay gelsin.