düşeyara- açıklamayı okuyunuz

[fs58]

Merhaba;

İlk sayfada iki hafta boyunca öğrencilerin sınıfa giriş tarih ve saatleri var tabi ki sırası karışık olarak.
ikinci sayfada ise dersi alan öğrencilerin listesi var. Bu listede sıra bozulmadan her öğrencinin hangi tarih ve saatlerde derse geldiğini nasıl yazdırabiliriz?

asıl excel (1).xlsb

drive.google.com

olmasını istediğim.xlsb

drive.google.com

 

[PLİNT]

Merhaba
Kodlarla işinize yararsa ek dosyayı inceleyiniz.
Listenin olduğu "sayfa1" aktif olduğunda kodlar çalışacaktır.
Asıl dosyanızda sayfa adları değişik ise; işaretli bölümdekilerle değiştirirsiniz.
https://www.dosyaupload.com/rUkK

Private Sub Worksheet_Activate()
Dim s1 As Worksheet, s2 As Worksheet
Dim x As Long, v As Long, i As Long, b As Long, n As Long
Dim c As Range
'-----------------------------------------
Set s1 = Sheets("YOKLAMA")
Set s2 = Sheets("Sayfa1")
'-----------------------------------
s2.Range("F2:G" & Rows.Count) = ""
a = Cells(Rows.Count, 1).End(xlUp).Row
s2.Range("B2:E" & s2.Cells(Rows.Count, 2).End(xlUp).Row).Sort Key1:=Cells(2, 2), Order1:=xlAscending
x = s1.Cells(Rows.Count, "F").End(3).Row
s2.Columns("F:F").NumberFormat = "m/d/yyyy"
s2.Columns("G:G").NumberFormat = "[$-F400]h:mm:ss AM/PM"
For a = 1 To x - 1
If WorksheetFunction.CountIf(s1.Range("F1:F" & a), s1.Cells(a, "F")) = 1 Then
    Set c = s2.Range("C:C").Find(Trim(s1.Cells(a, "F")), LookIn:=xlValues)
    If Not c Is Nothing Then
    s2.Range("F" & c.Row & ":G" & c.Row).Value = s1.Range("B" & a & ":C" & a).Value
n = WorksheetFunction.CountIf(s1.Range("F1:F" & x), s1.Cells(a, "F"))
If n > 1 Then
s2.Range("B" & c.Row + 1 & ":G" & c.Row + n - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For b = a + 1 To x
If s1.Cells(a, "F") = s1.Cells(b, "F") Then
For i = c.Row + 1 To c.Row + n - 1
s2.Range("F" & i & ":G" & i).Value = s1.Range("B" & b & ":C" & b).Value
Next
End If
Next
End If: End If: End If
Next
End Sub

 

[PLİNT]

Bir değişiklik yaptığım aşağıdaki dosyayı kulanınız
https://www.dosyaupload.com/rUkT

Private Sub Worksheet_Activate()
Dim s1 As Worksheet, s2 As Worksheet
Dim x As Long, v As Long, r As Long, b As Long, n As Long
Dim c As Range
Set s1 = Sheets("YOKLAMA")
Set s2 = Sheets("Sayfa1")
s2.Range("F2:G" & Rows.Count) = ""
a = Cells(Rows.Count, 1).End(xlUp).Row
s2.Range("B2:E" & s2.Cells(Rows.Count, 2).End(xlUp).Row).Sort Key1:=Cells(2, 2), Order1:=xlAscending
x = s1.Cells(Rows.Count, "F").End(3).Row
s2.Columns("F:F").NumberFormat = "m/d/yyyy"
s2.Columns("G:G").NumberFormat = "[$-F400]h:mm:ss AM/PM"
For a = 1 To x - 1
If WorksheetFunction.CountIf(s1.Range("F1:F" & a), s1.Cells(a, "F")) = 1 Then
    Set c = s2.Range("C:C").Find(Trim(s1.Cells(a, "F")), LookIn:=xlValues)
    If Not c Is Nothing Then
    s2.Range("F" & c.Row & ":G" & c.Row).Value = s1.Range("B" & a & ":C" & a).Value
n = WorksheetFunction.CountIf(s1.Range("F1:F" & x), s1.Cells(a, "F"))
If n > 1 Then
s2.Range("B" & c.Row + 1 & ":G" & c.Row + n).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For b = a + 1 To x
If s1.Cells(a, "F") = s1.Cells(b, "F") Then
r = r + 1
s2.Range("F" & c.Row + r & ":G" & c.Row + r).Value = s1.Range("B" & b & ":C" & b).Value
End If
Next
r = 0
End If: End If: End If
Next
End Sub

 

[fs58]

Çok çok teşekkürler sağ olun. Takıldığım yer olursa sorarım olur mu?

 

[muygun]

Merhaba;
Alternatif bir örnekte benden;
Deneyin.
İyi çalışmalar.

Link:

Hata indir

Hata

www.dosyaupload.com

 

[fs58]

Merhaba;
Alternatif bir örnekte benden;
Deneyin.
İyi çalışmalar.

Link:

Hata indir

Hata

www.dosyaupload.com

Harikasınız çok çok teşekkürler Allah razı olsun.

 

[muygun]

Kullanıcının;
"Geçenki hazırladığınız makroda ufak bir değişiklik gerekiyor. Tarih ve saatler alt alta değil de ismin yanında yani aynı satırda yan yana olması lazım. Rica etsem vakit ayırıp yapabilir misiniz? Çok sağ olun şimdiden. "
Özel mesajına istinaden;

Link:

Hata indir

Hata

www.dosyaupload.com

 

[fs58]

Kullanıcının;
"Geçenki hazırladığınız makroda ufak bir değişiklik gerekiyor. Tarih ve saatler alt alta değil de ismin yanında yani aynı satırda yan yana olması lazım. Rica etsem vakit ayırıp yapabilir misiniz? Çok sağ olun şimdiden. "
Özel mesajına istinaden;

Link:

Hata indir

Hata

www.dosyaupload.com

Tekrar çok teşekkürler çok makbule geçti sağ olun.