اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

  • تمت الإجابة
قام بنشر (معدل)

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

جرب هدا 


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

 

ScreenRecorderProject10.gif.03041d6d0efbcb0f1bac5e732925188f.gif

Book3.xlsb

تم تعديل بواسطه محمد هشام.
تعديل الكود
  • Like 1
  • Thanks 1
  • حسونة حسين changed the title to كود ترحيل من شيت الي شيت بعدة شروط
قام بنشر

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

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

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

يوجد شرطين 

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

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

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

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

 

قام بنشر

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

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

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

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

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

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

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

 

قام بنشر

اخي محمد

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

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

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

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

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

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

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

 

Screenshot 2025-06-29 183558.jpg

قام بنشر

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

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

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

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

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

قام بنشر (معدل)

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

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

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

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

غياب2.xlsm

تم تعديل بواسطه جلال محمد
قام بنشر (معدل)

 

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

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

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

تم تعديل بواسطه hegazee
  • Like 2

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   1 عضو متواجد الان

×
×
  • اضف...

Important Information