Başka sayfaya kaydetme

[zerali]

Bu çalışmada yapmak istediğim C1 deki öğrenciyle ilgili bilgileri işaretlediğimde öğrenci adı ile yeni bir sayfaya kaydetmesi.Modül adı da yazarsa daha da güzel olur.Yardımlarınız için şimdiden teşekkürler
https://s4.dosya.tc/server8/q3vi9v/iyep_kazanim.xlsx.html

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, Son As Integer, Say As Integer
    Dim S2 As Worksheet, Satir As Integer, X As Integer, Y As Integer
    
    Set S1 = Sheets("ana")
    Son = S1.Cells(Rows.Count, 3).End(3).Row
    
    On Error Resume Next
    Set S2 = Sheets(S1.Range("C1").Value)
    On Error GoTo 0
    
    If S2 Is Nothing Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        Set S2 = ActiveSheet
        S2.Name = S1.Range("C1")
        S2.Range("A1") = S2.Name
        S2.Range("A1").Font.Bold = True
        S2.Range("A3:D3") = Array("DERS MODÜL", "DERS SAATİ", "TÜRKÇE PROGRAM KAZANIMLARI", "TAMAMLADI")
        S2.Range("A3:D3").Font.Bold = True
        S2.Range("A3:D3").HorizontalAlignment = xlCenter
    Else
        S2.Range("A4:D" & Rows.Count).ClearContents
    End If
    
    Satir = 4
    
    For X = 4 To Son
        If S1.Cells(X, 1).MergeArea.Cells.Count > 1 Then
            If S1.Cells(X, 1).Value <> "Ders Modül" Then
                For Y = X To X + S1.Cells(X, 1).MergeArea.Cells.Count - 1
                    If S1.Cells(Y, 4) = "X" Then
                        S2.Cells(Satir, 1) = S1.Cells(X, 1).Value
                        S2.Cells(Satir, 2) = S1.Cells(X, 2).Value
                        S2.Cells(Satir, 3) = S1.Cells(Y, 3).Value
                        S2.Cells(Satir, 4) = S1.Cells(Y, 4).Value
                        Satir = Satir + 1
                        Say = Say + 1
                    End If
                Next
                X = Y - 1
            End If
        End If
    Next
    
    S2.Cells.EntireColumn.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    If Say = 0 Then
        MsgBox "Aktarılacak ders bilgisi bulunamamıştır.", vbCritical
    Else
        MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
    End If
End Sub

 

[zerali]

Çok teşekkürler Korhan hocam