İcmale Girilen Derslere İlişkin Liste Oluşturulması

[yenilik025]

Hocalarım merhabalar; Yapmaya Çalıştığım
Sınav Proğramı Sayfasına Girdiğim Derslere İlişkin Bilgileri

İcmal sayfasına
Dersin Adı, Tarih ve Sınav Saatlerini ve Sınav Yerini alt alta nasıl çekebilirim ?

Tarih ve Saat dikkate alınarak ?

 

[Muzaffer Ali]

Merhaba.
Dosyaya yeni bir module ekleyin aşağıdaki kodu kopyalayıp çalıştırın.

Sub Test()
    Dim Bak As Integer
    Dim syfPr As Worksheet, syfIc As Worksheet
    Dim Bul As Range
    
    Set syfIc = Worksheets("İcmal")
    Set syfPr = Worksheets("Sınav Programı")
    
    For Bak = 4 To syfIc.Cells(Rows.Count, "C").End(xlUp).Row
        Set Bul = syfPr.Range("C5:M" & syfPr.Cells(Rows.Count, "B").End(xlUp).Row).Find(what:=syfIc.Cells(Bak, "C"), lookat:=xlWhole)
        If Bul Is Nothing Then
            MsgBox syfIc.Cells(Bak, "C") & " adlı ders 'Sınav Programı' sayfasında bulunamıyor. Lütfen kontrol edip yeniden deneyiniz"
            Exit Sub
        Else
            syfIc.Cells(Bak, "D") = syfPr.Cells(Bul.Row, "A")
            syfIc.Cells(Bak, "E") = syfPr.Cells(Bul.Row, "B")
            syfIc.Cells(Bak, "F") = syfPr.Cells(4, Bul.Column)
            
        End If
    Next
End Sub

 

[dEdE]

Alternatif

Sub icmal()
Set ws1 = Sheets("Sınav Programı")
Set ws2 = Sheets("İcmal")
    ss1 = ws1.Cells(Rows.Count, "A").End(3).Row
    Sat = 4
   
    For i = 5 To ss1
        sk = ws1.Cells(i, Columns.Count).End(1).Column
        If sk > 2 Then
        'İKT1 ve İKT2 yi ayıracak net bigi olmadığı için ilgili kod satırı yazılmadı
            ws2.Cells(Sat, 3) = ws1.Cells(i, sk)
            ws2.Cells(Sat, 4) = ws1.Cells(i, 1)
            ws2.Cells(Sat, 5) = ws1.Cells(i, 2)
            ws2.Cells(Sat, 6) = ws1.Cells(4, sk)
            Sat = Sat + 1
        End If
    Next i
End Sub

 

[yenilik025]

Hocam teşekkür ederim istediğim gibi verileri geldi çok teşekkür ederim.

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[yenilik025]

Alternatif

Sub icmal()
Set ws1 = Sheets("Sınav Programı")
Set ws2 = Sheets("İcmal")
    ss1 = ws1.Cells(Rows.Count, "A").End(3).Row
    ss2 = ws2.Cells(Rows.Count, "A").End(3).Row
    Sat = 4
   
    For i = 5 To ss1
        sk = ws1.Cells(i, Columns.Count).End(1).Column
        If sk > 2 Then
        'İKT1 ve İKT2 yi ayıracak net bigi olmadığı için ilgili kod satırı yazılmadı
            ws2.Cells(Sat, 3) = ws1.Cells(i, sk)
            ws2.Cells(Sat, 4) = ws1.Cells(i, 1)
            ws2.Cells(Sat, 5) = ws1.Cells(i, 2)
            ws2.Cells(Sat, 6) = ws1.Cells(4, sk)
            Sat = Sat + 1
        End If
    Next i
End Sub

Hocam burada Sınıf Sayımızı artırdığımızda hangi değeri oynamamız gerekir.

B4-M4 arasında diyelim B1 den b20 YE Kadar artırdık o zaman kodun hangi kısmında oynama yapmalıyız.

 

[dEdE]

Merhaba,
Kodda bir değişiklik yapmaya gerek yok. İstediğiniz kadar artırabilirsiniz.

 

[yenilik025]

Merhaba,
Kodda bir değişiklik yapmaya gerek yok. İstediğiniz kadar artırabilirsiniz.

Hocam sanırım bir hata alıyorum dosyayı ekliyorum.
Farklı sınıflarda aynı saatte olan sınavı çekemedim.

 

[dEdE]

Merhaba,
İlk örneğinizde bu durum öngörülmemişti.
Dener misiniz?

Sub icmal()
Set ws1 = Sheets("Sınav Programı")
Set ws2 = Sheets("İcmal")
    ss1 = ws1.Cells(Rows.Count, "A").End(3).Row
    Sat = 4
    
For i = 5 To ss1
    sk = ws1.Cells(i, Columns.Count).End(1).Column
    If sk > 2 Then
        For j = 3 To sk
            If ws1.Cells(i, j) <> "" Then
                ws2.Cells(Sat, 3) = ws1.Cells(i, j)
                ws2.Cells(Sat, 4) = ws1.Cells(i, 1)
                ws2.Cells(Sat, 5) = ws1.Cells(i, 2)
                ws2.Cells(Sat, 6) = ws1.Cells(4, j)
            Sat = Sat + 1
            End If
        Next j
    End If
Next i
End Sub

 

[yenilik025]

Hocam çok teşekkür ederim gerçekten çok sağolun, uamrım bir çok kişinin de işini görecektir. Bilginize emeğinize sağlık.