كود ترحيل من شيت الي شيت بعدة شروط

[جلال محمد]

اريد ترحيل عمود السشن بما فية اسم المعلم حسب الاختيار من شيت2 الي شيت3 بشرط

تطابق التاريخ والكود ورقم السشن

Book2.xlsx

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

جرب هدا 

Option Explicit
Sub Transfer()
    Dim code As Variant, c As Boolean
    Dim tmp(0 To 4) As Boolean, xDate As String, f As Long, i As Long, j As Long
    Dim lr As Long, lastRow As Long, linge As Long, xCode As Boolean, Irow As Range
    Dim ColArr As Long, xName As String, n As Variant, val As Variant
   
    Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2")
    Dim Data As Worksheet: Set Data = Sheets("Sheet3")

    xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy")
    If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation: Exit Sub

    With Data
        For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column
            If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then
                f = ColArr: Exit For
            End If
        Next ColArr
        If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation: Exit Sub

        Set Irow = .Columns("E:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows)
        lr = IIf(Not Irow Is Nothing And Irow.row >= 5, Irow.row, 5)
        .Range(.Cells(5, f), .Cells(lr, f + 4)).ClearContents
    End With

    lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row
    xCode = False: c = False

    For i = 12 To lastRow
        code = CrWS.Cells(i, "C").Value
        If code <> "" Then
            linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).row
            n = Application.Match(code, Data.Range("D6:D" & linge), 0)
            If Not IsError(n) Then
                xCode = True
                For j = 0 To 4
                    xName = CrWS.Cells(10, 4 + j).Value
                    For ColArr = 0 To 4
                        If Data.Cells(4, f + ColArr).Value = xName Then
                            val = CrWS.Cells(i, 4 + j).Value
                            If Not IsEmpty(val) Then
                                Data.Cells(n + 5, f + ColArr).Value = val
                                c = True
                                If Not tmp(j) Then
                                    Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value
                                    tmp(j) = True
                                End If
                            End If
                            Exit For
                        End If
                    Next ColArr
                Next j
            End If
        End If
    Next i

Select Case True
    Case c
        MsgBox "تم ترحيل البيانات بنجاح", vbInformation
    Case Not xCode
        MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation
    Case Else
        MsgBox "لا توجد بيانات لترحيلها", vbInformation
End Select

End Sub

 

Book3.xlsb

تم تعديل منذ 5 ساعات بواسطه محمد هشام.
تعديل الكود

[جلال محمد]

شكرا جزيلا استاذ محمد تسلم ايدك

الكود يعمل بكل سهولة ولكن 

كان عندي ثلاث شروط للترحيل تحقق منها واحد وهو التاريخ

يوجد شرطين 

تطابق عمود الكود 

وتطابق رقم  السشن الذي يبدا برقم 1 الي 5

بمعني : عند دخول معلم الحصة الاولي عند الترحيل يتم ترحيل عمود الحصة الاولي فقط ... وهكذا

وشكرا لحضرتك علي مجهودك ووقتك 

 

[محمد هشام.]

أخي @جلال محمد الكود فعلا يتحقق من ثلاثة شروط 

التاريخ + الكود + رقم السشن 

بمعنى عند تحديد تاريخ معين يتم البحث عن مطابقة الكود في الورقتين وجلب بيانات عمود السشن المقابل لنفس الكود عند التحقق من وجوده الى الاعمدة الخاصة بكل سشن  وفي نفس نطاق التاريخ المحدد أعتقد أن هذا ما جاء في طلبك سابقا 

4 ساعات مضت, جلال محمد said:

عند دخول معلم الحصة الاولي عند الترحيل يتم ترحيل عمود الحصة الاولي فقط ... وهكذا

ممكن توضح هذه النقطة لو سمحت

هل تقصد أن يتم جلب قيمة اول سشن لكل معلم فقط عند العثور على اول كود وتجاهل الأكواد الموالية او ماذا؟

 

[جلال محمد]

اخي محمد

شاهد الصورة عند ترحيل البيانات في السشن رقم 1 تم الترحيل ولكن مقابل اكواد اخري 

اما بانسبة بالمقصود باول سشن 

اريد ترحيل كل عمود سشن منفصل وليس دفعة واحدة 

بمعني ان المعلم الاول يضع الغياب في عمود سشن 1 ويت ترحيلة 

ثم السشن الثاني يضع المعلم اغياب ويم ترحيلة 

وبمعني اخر يجب ترحيل عمود السشن الموجود به بيانات او علامة غياب 

واسف لعدم التوضيح مسبقا

 

[محمد هشام.]

لقد تم تعديل الكود في المشاركة السابقة لتتناسب مع طلبك يمكنك إعادة تحميل الملف من المرفقات 

مثال للنتائج المتوقعة :