مساعدة فى تعديل كود

[saad 77]

الاخوة الخبراء  الاعضاء السلام عليكم ورحمة الله وبركاته .

اعلم ان اسئلتي وطلباتي كثرة عليكم ربما اصابكم الملل من كثرة الطلبات لكن تحملوني واعلم انكم مشغولين لكن ارجوا المساعدة فيما يخص هذا الموضوع وجدت كود في هذا المنتدى وهو يضيف 10 درجات قرار للطالب المكمل بدرس او درسين او ثلاثة دروس لكن في هذا الكود درجة النجاح الصغرى 50 درجة ، بينما درجة النجاح الصغرى المراد تعديل الكود عليها 5 درجات المطلوب ممن يستطيع المساعدة هو

1- ان يضيف 5 درجات وليس 10 يعني يحذف 10 درجات ويضع مكانها 5 درجات درجة القرار المطلوبة.

2- الكود اثناء التنفيذ والفرز ثقيل جدا.

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

هذا صورة لمااريد وايضا ارفقت ملف للعمل عليه لا يحتوى على خلا يا مدمجة.

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

وهذا الكود

Sub Add_10Degrees()
    Application.ScreenUpdating = False

Dim R As Integer, M As Integer, N As Integer, o As Integer


    S_cl = Range("result").Column
    L_cl = Range("result").Columns.Count + S_cl - 1
    S_Rw = Range("result").Row
    L_Rw = Range("result").Rows.Count + S_Rw - 1
  
    For R = S_Rw To L_Rw
        adds = 10
            
            For c = S_cl To L_cl
                If Cells(R, c).Interior.ColorIndex = 3 Then GoTo 10
            Next c
            
            For c = S_cl To L_cl
                llimit = 50 - adds
                If Cells(R, c) < 50 And Cells(R, c) >= llimit Then
                    d = 50 - Cells(R, c)
                    Cells(R, c) = 50
                    adds = adds - d
                    Cells(R, c).Interior.ColorIndex = 3
                End If
                If adds < 1 Then GoTo 10
            Next c
            

10  Next R

    Sheets("ناجح").Range("A2:M100").ClearContents
    Sheets("مكمل").Range("A2:Y100").ClearContents
  
    M = 2: N = 2
   
  
    For R = 2 To 150
  
  
        If Cells(R, 13) = "ناجح" Then
            Range("A" & R).Resize(1, 13).Copy
          
            Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            M = M + 1
            
            ElseIf Cells(R, 13) = "مكمل" Then
            Range("A" & R).Resize(1, 24).Copy
          
            Sheets("مكمل").Range("A" & N).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
          
            N = N + 2
              

        End If
       Application.ScreenUpdating = False
  
    Next

    MsgBox ("الحمد لله تـــم اظافة 10 درجات وتم ترحيل الناجحين - والمكملين إلى أوراق عمل جديدة ")
    Application.ScreenUpdating = True
End Sub

وهذا ملف العمل 

ملف عمل.xlsm

[saad 77]

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

طلبت من الاخوة التعديل على كود لكن لم اجد رد وعندما قمت بنشر الموضوع مرة اخرى من حيث لا ادري ان تكرار نشر الموضوع يعد مخالفة ، اتمنى ان يكون لديك خبرة وتعدل على الكود الذي طلبت تعديله وجزاك الله خيرا.