Ekders ve Devam Devamsızlık

[asi_kartal]

slm arkadaşlar kendi yapmış olduğum ekders ve devam devamsızlık sayfalarını birleştirmek istiyorum. yanlız bi konuda takıldım ekteki dosyayı inceleyip bana yardımcı olursanız sevinirim.

 

[Korhan Ayhan]

Merhaba,

Verileri aktarmak sorun değil. Fakat açıklamanız yetersiz olmuş.

"EKDERS" sayfanızda isimler önceden olacakmı?
"CETVEL" sayfanızdaki sadece bir kişimi "EKDERS" sayfasına aktarılacak yoksa birden fazla kişiye ait bilgilermi aktarılacak?

 

[asi_kartal]

evet isimler önceden olacak.
"CETVEL" sayfasından da birden fazla kişi "EKDERS" sayfasına aktarılacak.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

EKDERS sayfası dolduğunda aktarım işlemi bitecektir.

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Range, BUL As Range, Y As Byte
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Cetvel")
    Set S2 = Sheets("EKDERS")
    
    For Each Veri In S1.Range("B9:B" & S1.Cells(Rows.Count, 2).End(3).Row + 2)
        Y = 6
        If Veri.Value <> "" Then
            Set BUL = S2.Range("D:D").Find(Veri.Value, , , xlWhole)
            If Not BUL Is Nothing Then
                
                If BUL.Row = 61 Then
                    MsgBox "EKDERS isimli sayfa dolmuştur." & Chr(10) & _
                    "Bu sebeple aktarım işlemi iptal edilmiştir.", vbCritical
                    
                    Set BUL = Nothing
                    Set S1 = Nothing
                    Set S2 = Nothing
                    
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
                
                For X = 5 To 66 Step 2
                    If S1.Cells(5, X) <> "Cumartesi" And S1.Cells(5, X) <> "Pazar" Then
                        S2.Cells(BUL.Row, Y) = S1.Cells(Veri.Row + 1, X)
                    End If
                    Y = Y + 1
                Next
            End If
        End If
    Next
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[asi_kartal]

sağolasın Korhan hocam ellerine sağlık

 

[asi_kartal]

hocam ikinci bir öğretmen eklediğimde tam istediğim yere aktarmıyor. bide ayın 30 ve 31 günlerini tam aktarmıyor.

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. Tekrar denermisiniz.

 

[asi_kartal]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. Tekrar denermisiniz.

teşekkürler şimdi oldu.