الاخوة الخبراء الاعضاء السلام عليكم ورحمة الله وبركاته .
اعلم ان اسئلتي وطلباتي كثرة عليكم ربما اصابكم الملل من كثرة الطلبات لكن تحملوني واعلم انكم مشغولين لكن ارجوا المساعدة فيما يخص هذا الموضوع وجدت كود في هذا المنتدى وهو يضيف 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
