Bir sayfadaki verileri birden fazla sayfalara T.C. Kimlik Numarasına göre veri aktarımı

[Bayram Paşa]

Üstatlarım;
Excelde bir sayfadaki verileri birden fazla sayfalara T.C. Kimlik Numarasına göre aktarma yapmak istiyorum. Bunu VBA koduyla nasıl yapabiliriz.
Göndereceğim excel dosyasında "İzin_Rapor" sayfası var. Bu sayfaya öğretmenler, izin, rapor, sevk aldıklarında ben o günler için; İzin için=İZ, Rapor İçin=Rp, Sevk için=S ve Tatil günleri içinde Tatil=T yazıyorum. Okula geldikleri, çalıştıkları günler için ise bir şey yazmıyorum. Yani o günler boş kalıyor.

Bu "İzin_Rapor" sayfasındaki sadece İZ, Rp, S ve T' ler diğer sayfalara Yani, "Gündüz", "Gece", "Nöbet", "Egzersiz", "İyep", "Belletmenlik", "Kurs" ve bunun gibi sayfalara aktarılacak, bu sayfadaki, İZ, Rp, S ve T haricindeki boş hücreler hiç aktarılmayacak, sadece dolu hücreler aktarılacak, boş hücreler aktarılmayacak. İZ, Rp, Sevk ve T harflerini burada belirtmiş olduğum sayfalara sadece T.C. kimlik numaraları dikkate alarak aktarma yapmak istiyorum. Yardımcı olursanız çok memnun olurum.

 

[Korhan Ayhan]

Ana sayfadaki verileriniz aşağıdaki sayfaların hepsine mi aktarılacak?

"Gündüz", "Gece", "Nöbet", "Egzersiz", "İyep", "Belletmenlik", "Kurs"

 

[Bayram Paşa]

Evet Korhan bey. Bu sayfalara aktarılacak

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Sayfalara_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Sayfalar As Variant, Sayfa As Variant
    Dim Son As Long, X As Long, Veri As Variant
    Dim Bul As Range, Y As Integer, Say As Long
    
    With Application
        .ScreenUpdating = 0
        .Calculation = -4135
    End With
    
    Set S1 = Sheets("İzin_Rapor")
    
    Sayfalar = Array("Gündüz", "Gece", "Nöbet", "Egzersiz", "İyep", "Belletmenlik", "Kurs")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 8 Then Son = 8
    
    Veri = S1.Range("A7:Bg" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Each Sayfa In Sayfalar
            On Error Resume Next
            Set S2 = Nothing
            Set S2 = Sheets(Sayfa)
            On Error GoTo 0
            If Not S2 Is Nothing Then
                Set Bul = S2.Range("F:F").Find(Veri(X, 6), , , xlWhole)
                If Not Bul Is Nothing Then
                    For Y = 13 To 59
                        Select Case Veri(X, Y)
                            Case "İZ", "Rp", "S", "T"
                                S2.Cells(Bul.Row, Y) = Veri(X, Y)
                                Say = Say + 1
                        End Select
                    Next
                End If
            End If
        Next
    Next
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    With Application
        .ScreenUpdating = 1
        .Calculation = -4105
    End With
    
    If Say > 0 Then
        MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı!", vbExclamation
    End If
End Sub

 

[Bayram Paşa]

Korhan bey çok teşekkür ederim. Ellerinize, gönlünüze sağlık.

 

[Bayram Paşa]

Korhan hocam, emeğiniz gerçekten çok büyük. Sizlere zahmet veriyorum.
Fakat buradaki İzin_Rapor sayfasından aktaracağımız Rp, İZ, S, T harfleriyle sınırlı olmasın, bir de büyük küçük harf duyarlılığı olmasın. Yani ben bunların yerine bazen Rp yerine R yazabileyim. Bir de bazı durumlarda rakam da yazmam gerekebiliyor. (Mesele bir öğretmenin o gün 6 saat dersi vardı ve sabahtan 4 ders saatini girdi, hasta oldu sevk aldı. Son iki saati girmedi. İşte böyle durumda ben o gün için buraya 4 yazacağım)

 

[Korhan Ayhan]

Bir karar vermelisiniz. Ben bu tarz taleplerden hiç hoşlanmadığımı ifade etmek istiyorum.

Bu "İzin_Rapor" sayfasındaki sadece İZ, Rp, S ve T' ler diğer sayfalara Yani, "Gündüz", "Gece", "Nöbet", "Egzersiz", "İyep", "Belletmenlik", "Kurs" ve bunun gibi sayfalara aktarılacak,

 

[Bayram Paşa]

Tamam Korhan hocam teşekkür ederim. Sağolasın.