نامل التعديل على هذين الكودين

[عبدالسلام علي]

Sub ali_Fail_Students()

    Sheets("الناجحون").Range("a6:aq100") = ""
    Sheets("الناجحون").Range("a6:aq100").Interior.ColorIndex = 0

    Application.ScreenUpdating = False

    X = Sheets("تجميعي").[e1000].End(xlUp).Row

    For T = 11 To X Step 3
    
        Y = Sheets("الناجحون").[A1000].End(xlUp).Row + 1

        If Sheets("تجميعي").Range("au" & T).Value = "ناجح" Then
            Sheets("الناجحون").Range("a" & Y) = Sheets("تجميعي").Range("E" & T).Value
            Sheets("الناجحون").Range("d" & Y) = Sheets("تجميعي").Range("g" & T).Value
             Sheets("الناجحون").Range("c" & Y) = Sheets("تجميعي").Range("f" & T).Value
            Sheets("الناجحون").Range("e" & Y & ":aq" & Y) = Sheets("تجميعي").Range("j" & T + 2 & ":av" & T + 2).Value
    Else
    End If
    Next
    
    Clear_and_Highlight
    Application.ScreenUpdating = True
End Sub
Sub rakan_Fail_Students()

    Sheets("راسب").Range("a6:aq100") = ""
    Sheets("راسب").Range("a6:aq100").Interior.ColorIndex = 0

    Application.ScreenUpdating = False

    X = Sheets("تجميعي").[e1000].End(xlUp).Row

    For T = 11 To X Step 3
    
        Y = Sheets("راسب").[A1000].End(xlUp).Row + 1

        If Sheets("تجميعي").Range("au" & T).Value = "له دور ثان فى" Then
            Sheets("راسب").Range("a" & Y) = Sheets("تجميعي").Range("E" & T).Value
            Sheets("راسب").Range("d" & Y) = Sheets("تجميعي").Range("g" & T).Value
             Sheets("راسب").Range("c" & Y) = Sheets("تجميعي").Range("f" & T).Value
            Sheets("راسب").Range("e" & Y & ":aq" & Y) = Sheets("تجميعي").Range("j" & T + 2 & ":av" & T + 2).Value
    Else
    End If
    Next
    
    Clear_and_Highlight
    Application.ScreenUpdating = True
End Sub

هذين الكودين للترحيل يعملان كلا على حدى اي زر لترحيل الناجحين وزر لترحيل الراسبين 

المطلوب رب هذين الكودين بزر واحد يقوم بترحيل الناجحين والراسبين دفعة واحدة

 

                                                                                                                                                                                                                                                                                                     

 

[ياسر خليل أبو البراء]

أخي الكريم يرجى إرفاق ملف لتتضح صورة طلبك ولتجد استجابة أفضل في الموضوع كما يرجى ذكر المطلوب بالتفصيل .. لا يجب الشرح بشكل عام

تحدث بلغة الإكسيل كأن تقول في ورقة كذا والخلية كذا والنطاق كذا ..

 

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

Sub Test()
    Call ali_Fail_Students
    Call rakan_Fail_Students
End Sub

 

[عبدالسلام علي]

اشكرك استاذي الفاضل ياسر

اولا :- لعدم رفع الملف كبير الحجم لم استطع رفعه

وثانيا :- الكود الذي كتبته هذا ما اريده فعلا وجزاك الله كل خير وفي ميزان حسناتك

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير

تقبل تحياتي وكل عام وأنت بخير

[قلم-الاكسل(عبدالعزيز)]

رائع كالعادة المهندس ياسر جاوبت باقل مجهود فكان المطلوب باركك الله

 

[ابو عبدالبارى]

23 ساعات مضت, عبدالسلام علي said:

Sub ali_Fail_Students()

    Sheets("الناجحون").Range("a6:aq100") = ""
    Sheets("الناجحون").Range("a6:aq100").Interior.ColorIndex = 0

    Application.ScreenUpdating = False

    X = Sheets("تجميعي").[e1000].End(xlUp).Row

    For T = 11 To X Step 3
    
        Y = Sheets("الناجحون").[A1000].End(xlUp).Row + 1

        If Sheets("تجميعي").Range("au" & T).Value = "ناجح" Then
            Sheets("الناجحون").Range("a" & Y) = Sheets("تجميعي").Range("E" & T).Value
            Sheets("الناجحون").Range("d" & Y) = Sheets("تجميعي").Range("g" & T).Value
             Sheets("الناجحون").Range("c" & Y) = Sheets("تجميعي").Range("f" & T).Value
            Sheets("الناجحون").Range("e" & Y & ":aq" & Y) = Sheets("تجميعي").Range("j" & T + 2 & ":av" & T + 2).Value
    Else
    End If
    Next
    
    Clear_and_Highlight
    Application.ScreenUpdating = True
End Sub
Sub rakan_Fail_Students()

    Sheets("راسب").Range("a6:aq100") = ""
    Sheets("راسب").Range("a6:aq100").Interior.ColorIndex = 0

    Application.ScreenUpdating = False

    X = Sheets("تجميعي").[e1000].End(xlUp).Row

    For T = 11 To X Step 3
    
        Y = Sheets("راسب").[A1000].End(xlUp).Row + 1

        If Sheets("تجميعي").Range("au" & T).Value = "له دور ثان فى" Then
            Sheets("راسب").Range("a" & Y) = Sheets("تجميعي").Range("E" & T).Value
            Sheets("راسب").Range("d" & Y) = Sheets("تجميعي").Range("g" & T).Value
             Sheets("راسب").Range("c" & Y) = Sheets("تجميعي").Range("f" & T).Value
            Sheets("راسب").Range("e" & Y & ":aq" & Y) = Sheets("تجميعي").Range("j" & T + 2 & ":av" & T + 2).Value
    Else
    End If
    Next
    
    Clear_and_Highlight
    Application.ScreenUpdating = True
End Sub

هذين الكودين للترحيل يعملان كلا على حدى اي زر لترحيل الناجحين وزر لترحيل الراسبين 

المطلوب رب هذين الكودين بزر واحد يقوم بترحيل الناجحين والراسبين دفعة واحدة

 

                                                                                                                                                                                                                                                                                                     

 

الأخ العزيز عبدالسلام علي

السلام عليكم

جرب هذا الكود بعد دمجة لعلة يكون المطلويب باذن الله نسألكم الدعاء

Sub abo_abary()
 Sheets("ÇáäÇÌÍæä").Range("a6:aq100") = ""
    Sheets("ÇáäÇÌÍæä").Range("a6:aq100").Interior.ColorIndex = 0
 Sheets("ÑÇÓÈ").Range("a6:aq100") = ""
    Sheets("ÑÇÓÈ").Range("a6:aq100").Interior.ColorIndex = 0
    Application.ScreenUpdating = False
    X = Sheets("ÊÌãíÚí").[e1000].End(xlUp).Row
  For T = 11 To X Step 3
      Y = Sheets("ÇáäÇÌÍæä").[A1000].End(xlUp).Row + 1
        If Sheets("ÊÌãíÚí").Range("au" & T).Value = "äÇÌÍ" Then
            Sheets("ÇáäÇÌÍæä").Range("a" & Y) = Sheets("ÊÌãíÚí").Range("E" & T).Value
            Sheets("ÇáäÇÌÍæä").Range("d" & Y) = Sheets("ÊÌãíÚí").Range("g" & T).Value
             Sheets("ÇáäÇÌÍæä").Range("c" & Y) = Sheets("ÊÌãíÚí").Range("f" & T).Value
            Sheets("ÇáäÇÌÍæä").Range("e" & Y & ":aq" & Y) = Sheets("ÊÌãíÚí").Range("j" & T + 2 & ":av" & T + 2).Value
   
   ElseIf Sheets("ÊÌãíÚí").Range("au" & T).Value = "áå ÏæÑ ËÇä Ýì" Then
            Sheets("ÑÇÓÈ").Range("a" & Y) = Sheets("ÊÌãíÚí").Range("E" & T).Value
            Sheets("ÑÇÓÈ").Range("d" & Y) = Sheets("ÊÌãíÚí").Range("g" & T).Value
             Sheets("ÑÇÓÈ").Range("c" & Y) = Sheets("ÊÌãíÚí").Range("f" & T).Value
            Sheets("ÑÇÓÈ").Range("e" & Y & ":aq" & Y) = Sheets("ÊÌãíÚí").Range("j" & T + 2 & ":av" & T + 2).Value
 End If
    Next
        Clear_and_Highlight
    Application.ScreenUpdating = True
End Sub

 

[عبدالسلام علي]

السلام عليكم اخي ابو عبدالباري 

كل العام وانت بالف خير  واشكر اهتمامك