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

[جلال محمد]

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

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

[جلال محمد]

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

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

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

يوجد شرطين 

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

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

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

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