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

[جلال محمد]

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

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

Book2.xlsx

[محمد هشام.]

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

جرب هدا 

Option Explicit
Sub Transfer()
    Dim a As Long, b As Long, colMap(0 To 4) As Long, tmp(0 To 4) As Boolean
    Dim srcArr As Variant, destArr As Variant, dict As Object, i As Long, j As Long, f As Long, lr As Long
    Dim xDate As String, lastRow As Long, xName As String, c As Boolean, xCode As Boolean, Irow As Range, val

    Dim CrWS As Worksheet, Data As Worksheet
    Set CrWS = Sheets("Sheet2"): Set Data = Sheets("Sheet3")
    Set dict = CreateObject("Scripting.Dictionary")

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

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

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

    lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row
    srcArr = CrWS.Range("C12:H" & lastRow).Value

    For i = 6 To Data.Cells(Data.Rows.Count, "D").End(xlUp).row
        If Not dict.exists(Data.Cells(i, "D").Value) Then
            dict(Data.Cells(i, "D").Value) = i
        End If
    Next

    For j = 0 To 4
        xName = CrWS.Cells(10, 4 + j).Value
        For b = 0 To 4
            If Data.Cells(4, f + b).Value = xName Then
                colMap(j) = f + b
                Exit For
            End If
        Next
    Next

    For i = 1 To UBound(srcArr, 1)
        If srcArr(i, 1) <> "" Then
            If dict.exists(srcArr(i, 1)) Then
                xCode = True
                For j = 1 To 5
                    val = srcArr(i, j + 1)
                    If Not IsEmpty(val) Then
                        c = True
                        Data.Cells(dict(srcArr(i, 1)) + 5, colMap(j - 1)).Value = val
                        If Not tmp(j - 1) Then
                            Data.Cells(5, colMap(j - 1)).Value = CrWS.Cells(11, 3 + j).Value
                            tmp(j - 1) = True
                        End If
                    End If
                Next
            End If
        End If
    Next

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

 

Book2 -v2.xlsb

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

[جلال محمد]

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

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

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

يوجد شرطين 

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

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

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

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

 

[محمد هشام.]

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

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

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

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

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

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

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

 

[جلال محمد]

اخي محمد

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

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

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

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

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

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

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