Soru Sınıf Listesi Güncelleme

[Feylosof]

Hepinize hayırlı günler dilerim.

Sizlerden bir istirhamım olacak. Liste sayfasından Yoklama sayfasına 32 adet sınıfın listesini Sarı renkli hücrelerde yazan sınıflara göre aktaracak kod yazdırmak istiyorum.
Şİmdiden teşekkür ederim.

 

[ÖmerFaruk]

Sayın Feylosof,
Dosyanızda Liste sayfası yok, Yoklama sayfası yok, Sarı Renkli hücre yok.

 

[Feylosof]

Sayın Feylosof,
Dosyanızda Liste sayfası yok, Yoklama sayfası yok, Sarı Renkli hücre yok.

Çok özür dilerim @ÖmerFaruk Bey yanlış dosya yüklemişim. Dosya evdeki bilgisayarda akşam tekrar yükleyeceğim artık. Tekrar tekrar tekrar özür dilerim. Kusura bakmayın ne olur sabahın etkisi

 

[Feylosof]

Yanlış eklediğim dosyanın doğrusunu yükledim.

 

[ÖmerFaruk]

Aşağıdaki kodları boş bir Module içine ekleyip butona atayabilirsiniz.

Sub ListeleriDoldur()
Dim Bul As Range, BulAdres As String, TimerStart As Double, SonSat As Long, xSon As Integer

TimerStart = Timer
SonSat = Worksheets("Yoklama").Range("A" & Rows.Count).End(3).Row
Set Bul = Worksheets("Yoklama").Range("A2:A" & SonSat).Find("SIRA", , , xlWhole)
If Bul Is Nothing Then Exit Sub
BulAdres = Bul.Address
    Do
        xSon = Worksheets("Yoklama").Range("A" & Bul.Row).End(xlDown).Row - 1
        Worksheets("Yoklama").Range("B" & Bul.Row + 2, "C" & xSon).ClearContents
        Call ADO_Liste(Range("A" & Bul.Row - 2).Value, Bul.Row + 2)
        Set Bul = Worksheets("Yoklama").Range("A2:A" & SonSat).FindNext(Bul)
    Loop While Bul.Address <> BulAdres

MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - TimerStart, "0.00") & " Saniye", vbInformation
End Sub

Sub ADO_Liste(xSınıf As String, xFirstRow As Long)
    Dim ifade As String, MyCn  As Object, MyRs As Object

    Set MyCn = CreateObject("ADODB.Connection")
    Set MyRs = CreateObject("adodb.recordset")
    MyCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    MyCn.Properties("Data Source") = ThisWorkbook.FullName
    MyCn.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    MyCn.Open
    ifade = "Select Top 50 [No], [Adı Soyadı] from [Liste$] Where [Sınıf]= '" & xSınıf & "'  Order By [No]"
    MyRs.Open ifade, MyCn, 1, 1
    If MyRs.RecordCount > 0 Then
        Sheets("Yoklama").Range("B" & xFirstRow).CopyFromRecordset MyRs
    End If
    MyRs.Close
    MyCn.Close
    Set MyCn = Nothing: Set MyRs = Nothing: ifade = ""
End Sub

 

[Feylosof]

Derhal. Hemen inceliyor ve size bilgi veriyorum. @ÖmerFaruk üstadım.

 

[ÖmerFaruk]

Belirtmem gereken 2 tane kısıtınız var.

1. 1. Yoklama Sayfasında SIRA ifadesi daima Sınıf adının altındaki hücrede olmalı. Hücre birleştirme yaptığınız için sınıfın 2 altında olacak
2. 2. Yine yoklama sayfasında, SIRA ifadesinin bulunduğu satırdan her bir sınıf için olan İMZA yazılı C sütunundaki satıra denk gelen A sütunu aralığı dolu ve bir altı da boş olmalı. Mesela ilk sınıf için A4:A56 arası dolu ve A57 boş.

 

[Feylosof]

@ÖmerFaruk üstadım. Konu anlaşılmıştır. Geniş boş satırlar okul başlığı için tasarlandı. Sınıfın altında birer boş satır bırakıldı. Gerçek verilerimin olduğu dosyaya tatbik edildi ve başarıyla çalıştığı görüldü. Kurgusunun zor olduğuna inandığım bu kodu hızlı bir şekilde yazarak gerçek bir usta olduğunuzu ispat ettiniz. Minnettarım. Eliniz dert görmesin.

 

[ÖmerFaruk]

Eyvallah.
Ancak soru çözerek Excel öğrenmeyi çok seviyorum sadece.
Forumdaki bir çok yetkili ve etkili arkadaş varken usta ifadesini üzerime almıyorum.
Had bilmek de güzel kendi adıma...

 

[Haluk]

Alternatif olarak, VBA veya formül kullanmadan ekli dosyadaki gibi "Pivot Tablo" kullanılabilir....

.