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

[جلال محمد]

اريد ترحيل عمود السشن بما فية اسم المعلم حسب الاختيار من شيت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

تم تعديل الأحد at 17:44 بواسطه محمد هشام.
تعديل الكود

[جلال محمد]

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

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

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

يوجد شرطين 

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

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

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

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

 

[محمد هشام.]

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

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

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

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

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

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

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

 

[جلال محمد]

اخي محمد

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

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

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

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

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

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

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

 

[محمد هشام.]

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

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

 

 

[جلال محمد]

بسم الله مشاء الله

تسلم ايدك استاذ محمد 

دا المطلوب بعينه ... الله ينور عليك

واسف جدا علي تعب حضرتك 

جعله الله في موازين حسناتك ان شاء الله

[جلال محمد]

السلام عليكم اخي محمد 

بعد تجربة الكود علي اكثر من فصل تحدث مشكله 

بعد ترحيل السشن الاول لفصل 1Aيتم الترحيل تمام

عند اختيار فصل تاني مثل 1B يقوم الكود بمسح غياب الفصل السابق ... وهكذا .. شاهد المرفق ... اختر الفصل من D3 ثم اختر التايخ من D2 يتم استدعاء الفصل

غياب2.xlsm

تم تعديل منذ 14 ساعات بواسطه جلال محمد

[hegazee]

 

بعد إذن الاستاذ/ هشام

جرب كود الأستاذ/هشام بعد تعديل بسيط 

Option Explicit
Sub Transfer()
    Dim code As Variant, c As Boolean
    Dim tmp(0 To 4) As Boolean, xDate As String
    Dim f As Long, i As Long, j As Long
    Dim linge As Long, xCode As Boolean, Irow As Range
    Dim ColArr As Long, xName As String, n As Variant, val As Variant
    Dim lastRow As Long

    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
    End If

    ' البحث عن العمود المطابق للتاريخ في الصف 3
    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
        End If
    End With

    ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2
    lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row
    xCode = False: c = False

    ' البدء من الصف 11 حتى يشمل أول طالب
    For i = 11 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 ColArr = 0 To 4
                    Data.Cells(n + 5, f + ColArr).ClearContents
                Next ColArr

                ' نقل القيم
                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

    ' رسائل النهاية
    If Not xCode Then
        MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation
    ElseIf c Then
        MsgBox "تم ترحيل البيانات بنجاح", vbInformation
    Else
        MsgBox "لا توجد بيانات لترحيلها", vbInformation
    End If

End Sub

 

غياب3.xlsm

تم تعديل منذ 13 ساعات بواسطه hegazee

[جلال محمد]

تمام ... شكرا استاذ حجازى

جزاك الله كل خير علي جميل عملك وسرعة الرد