Birden fazla sayfadan iki şartlı veriye göre tek bir sayfaya veri aktarma

[Bayram Paşa]

Ek ders Puantajı adlı excel dosyamda farklı sayfalarda GÜNDÜZ, GECE, NÖBET, KURS gibi sayfalar var. Bu sayfalardaki verileri T.C. Kimlik ve Kod numaralarına göre PUANTAJ adlı sayfaya ve bu PUANTAJ sayfasındaki T.C. Kimlik No ve Koda göre VBA koduyla aktarmak istiyorum. Yardımlarınız için şimdiden çok teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.
Not: Kırmızı renkle belirttiğim kısımdaki kodlarla sayfa isimlerinin doğru eşleştiğinden emin olunuz.

Sub Kod()
Dim S1 As Worksheet, S2 As Worksheet
Dim a As Integer, s As Integer
Dim tc As Long
Dim sayfa As String
Set S1 = Sheets("PUANTAJ")
s = S1.Cells(Rows.Count, "H").End(3).Row
Application.ScreenUpdating = False
S1.Range("M6:BH" & s).ClearContents
For a = 6 To s
    tc = S1.Cells(a, "F")
    sayfa = syf(S1.Cells(a, "H"))
    If sayfa = "YOK" Then
        MsgBox "Kod hatası:" & vbLf & a & ". satır: " & S1.Cells(a, "H"), vbCritical
        Exit Sub
    Else
        Set S2 = Sheets(sayfa)
        For b = 9 To S2.Cells(Rows.Count, "F").End(3).Row
            If S2.Cells(b, "F") = tc Then
                S1.Range("M" & a & ":BH" & a).Value = S2.Range("M" & b & ":BH" & b).Value
                Exit For
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
MsgBox "Aktarım bitti."
End Sub

Private Function syf(kd)
Select Case kd
Case 101
    syf = "GÜNDÜZ"
Case 108
    syf = "EGZERSİZ"
Case 109
    syf = "NÖBET"
Case 111
    syf = "KURS"
Case 119
    syf = "GECE"
Case Else
    syf = "YOK"
End Select
End Function

 

[Bayram Paşa]

Ömer bey çok teşekkür ederim. Allah razı olsun. Kodlar gayet güzel çalışıyor. Ancak. Ben buraya göndermiş olduğum program programımın bir parçasıydı. Bu kodları asıl programa uyguladım ancak hata verdi. Hatayı bir türlü düzeltemedim. Buradaki örnek göndermiş olduğum programda işlemler 6. satırdan başlıyordu. Ama şimdi göndereceğim programda ise 7. satırda başlıyor. kodlardan düzelttim ancak bir türlü başarılı olamadım. Sizin için çok kolay bir durum. Tekrar yardımcı olursanız. minnettar olurum. Saygılarımla... programı gönderiyorum.

 

[ÖmerBey]

Buyurunuz...
Koda göre sayfa isimlerinin belirlendiği kısma müdahale etmedim. Onu da modüle ilave edersiniz.

Sub Kod()
Dim S1 As Worksheet, S2 As Worksheet
Dim a As Integer, s As Integer
Dim tc As Double
Dim sayfa As String
Set S1 = Sheets("FiilenGirEkDers")
s = S1.Cells(Rows.Count, "H").End(3).Row
Application.ScreenUpdating = False
S1.Range("M7:BH" & s).ClearContents
For a = 7 To s
    tc = S1.Cells(a, "F")
    sayfa = syf(S1.Cells(a, "H"))
    If sayfa = "YOK" Then
        MsgBox "Kod hatası:" & vbLf & a & ". satır: " & S1.Cells(a, "H"), vbCritical
        Exit Sub
    Else
        Set S2 = Sheets(sayfa)
        For b = 6 To S2.Cells(Rows.Count, "C").End(3).Row
            If S2.Cells(b, "C") = tc Then
                S1.Range("M" & a & ":BH" & a).Value = S2.Range("F" & b & ":BA" & b).Value
                Exit For
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
MsgBox "Aktarım bitti."
End Sub

 

[Bayram Paşa]

Ömer yine aynı hatayı veriyor.
Run time error 6
Overflow hatası veriyor
Debug deyince de 11. satırdaki kodu

tc = S1.Cells(a, "F") yi sarı renkte gösteriyor


ub Kod()
Dim S1 As Worksheet, S2 As Worksheet
Dim a As Integer, s As Integer
Dim tc As Long
Dim sayfa As String
Set S1 = Sheets("FiilenGirEkDers")
s = S1.Cells(Rows.Count, "H").End(3).Row
Application.ScreenUpdating = False
S1.Range("M7:BH" & s).ClearContents
For a = 7 To s
tc = S1.Cells(a, "F")
sayfa = syf(S1.Cells(a, "H"))
If sayfa = "YOK" Then
MsgBox "Kod hatası:" & vbLf & a & ". satır: " & S1.Cells(a, "H"), vbCritical
Exit Sub
Else
Set S2 = Sheets(sayfa)
For b = 6 To S2.Cells(Rows.Count, "C").End(3).Row
If S2.Cells(b, "C") = tc Then
S1.Range("M" & a & ":BH" & a).Value = S2.Range("F" & b & ":BA" & b).Value
Exit For
End If
Next
End If
Next
Application.ScreenUpdating = True
MsgBox "Aktarım bitti."
End Sub

 

[Bayram Paşa]

Sanki burada bir format var ve o formattan kaynaklı gibi geldi bana

 

[ÖmerBey]

Çok haklısınız, tanımlamayla ilgili ciddi bir hata yapmışım.
Dim tc As Long satırını Dim tc As Double olarak değiştirip deneyiniz...
Ya da yukarıdaki mesajımı güncelledim, oradan alabilirsiniz.

 

[Bayram Paşa]

Ömer bey Çok Teşekkür Ederim. Şu an bir problem görünmüyor.
Allah sizden razı olsun.

 

[ÖmerBey]

Allah hepimizden razı olsun,
İyi çalışmalar...

 

[Bayram Paşa]

Ömer bey zamanınızı alıyorum hakkınızı helal ediniz.
Bir durum daha var. eğer o da olursa çok şahane olacak.
Aynı programda "İzin_Rapor" sayfası var. Bu sayfaya öğretmenler izin, rapor, sevk aldıklarında ben o günler için İzin için=İ, Rapor İçin=R, Sevk için=S ve Tatil günleri içinde Tatil=T yazacağım. Okula geldikleri günler için bir şey yazmayacağım. Yani boş kalacak.
"FiilenGirEkDers" sayfasına tüm sayfalardaki görevler aktarıldıktan sonra "İzin_Rapor" sayfasındaki sadece bu İ, R, S ve T ler aktarılacak, bu sayfadaki, İ, R, S ve T hariç boş hücreler hiç aktarılmayacak, sadece İ, R, S ve T harflerini "FiilenGirEkDers" sayfasına sadece T.C. kimlik numaralar dikkate alınarak aktarma yapmak istiyorum. Kolaylıklar diliyorum
Dosyayı gönderiyorum.

 

[Bayram Paşa]

Bir önceki dosyayı dikkate almayın

 

[Bayram Paşa]

Bu konuda çözüm yok mu acaba?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Izin_Rapor_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Son As Long
    Dim X As Long, Y As Integer, Tc_Bul As Range, Gun_Bul As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("FiilenGirEkDers")
    Set S2 = Sheets("İzin_Rapor")
    
    Son = S1.Cells(S1.Rows.Count, "F").End(3).Row
    
    For X = 7 To Son
        If S1.Cells(X, "F") <> "" Then
            Set Tc_Bul = S2.Range("F:F").Find(S1.Cells(X, "F"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not Tc_Bul Is Nothing Then
                For Y = 13 To 60
                    If S1.Cells(5, Y) <> "" Then
                        Set Gun_Bul = S2.Range("5:5").Find(S1.Cells(5, Y), , , xlWhole)
                        If Not Gun_Bul Is Nothing Then
                            If S2.Cells(Tc_Bul.Row, Gun_Bul.Column) <> "" Then
                                S1.Cells(X, Y) = S2.Cells(Tc_Bul.Row, Gun_Bul.Column)
                            End If
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    Set Tc_Bul = Nothing
    Set Gun_Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = True

    MsgBox "İzin ve rapor bilgileri aktarılmıştır.", vbInformation
End Sub

 

[Bayram Paşa]

Üstadım. Çok güzel olmuş.
Emeğinize, yüreğinize sağlık. Çok teşekkür ederim. İyi ki varsınız. Allah sizden razı olsun.

 

[Bayram Paşa]

Ömer bey hayırlı günler diliyorum.
Bana bu konuda çok yardımcı olmuştunuz. Allah razı olsun .
Şimdi bu konuyla ilgili biraz daha farkı bir durum var.
Yukarıdaki yardımcı olduğunuz konu ile çok yakından ilgili bir durum. Yukarıda kullandığınız kodlar var zaten. Belki de küçük bir kod değişikliğiyle bu çözülebilecek. Ancak ben yapamadım. Yardımcı olursanız çok memnun olurum.
Göndereceğim programda "İ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 yazmayacağım. Yani boş kalacak.

Bu "İzin_Rapor" sayfasındaki sadece bu İ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 İZ, Rp, Sevk ve T harflerini burada belirtmiş olduğum sayfalara sadece T.C. kimlik numaraları dikkate alarak aktarma yapmak istiyorum.
Dosyayı gönderiyorum.