تعديل الكود ليتغاضى عن إضافة درجة القرار للطلاب الراسبين

[saad 77]

السلام عليكم .. لابد من التحية عند بدء أى مشاركة ,,اساتذتي اخوتي 
لدي ورقة عمل فيها درجات الطلاب وتم اضافة درجات القرار للطلاب واثناء الاضافة تحدث اخطاء في الاضافة حيث يحدث في بعض الاحيان ان تكون القائمة طويلة ومتعبة فيحدث اضافة سهوا لطالب في الاساس هو راسب ولا يجوز اضافة درجة القرار له في الملف كود يقوم بالتراجع عن اضافة درجات القرار لكنه يقوم بالتراجع عن جميع الدرجات ماريده هو التعديل على هذا الكود بحيث انه يقوم بالتراجع عن اضافة درجة القرار للطلاب الراسبون فقط الموجودة في العمود(R6:R45) ويترك بقية الدرجات على حالها بعد اضافة القرار . وجزاكم الله خيرا  ..انتبه من فضلك عنوان مخالف ..تــــم تعديل عنوان المشاركة ليتماشى مع طلبك
تراجع.xlsm

[saad 77]

السلام عليكم 

اخي واستاذي Mohamed Hicham في المرفق الذي ارفقته في مشاركتي الاولى كود يقوم عند الضغط عليه بالتراجع عن الاجراءات التي كانت موجودة لكنه يتراجع عن جميع الدرجات التي تم تغييرها مااطلبه هو ان يتراجع الكود فقط عن الدرجات المضافة للطالب الراسب فقط لانه في الاساس راسب ولا يجوز اضافة الفرار له

[محمد هشام.]

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

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

Sub Undo_add_change()
Dim Sheet As Worksheet
Dim liste1 As Variant
Dim liste2 As Variant
Dim MH As Long
Dim Rng As Range
Set Sheet = Sheets("سجل وسط نهاية السنة")
Set Rng = Range("d6:L45")

Application.ScreenUpdating = False

For i = 6 To 45
liste1 = Array("49.5 50", "49 50", "48.5 50", "48 50", "47.5 50", "47 50", "46.5 50", "46 50", "45.5 50", "45 50")
liste2 = Array("49.5", "49", "48.5", "48", "47.5", "47", "46.5", "46", "45.5", "45")
         For MH = LBound(liste1) To UBound(liste1)
  
If Range("R" & i).Value = "راسب" Then
Range("d" & i, "k" & i).Cells.Replace What:=liste1(MH), Replacement:=liste2(MH), _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, _
                        SearchFormat:=True, ReplaceFormat:=True
 
                 End If     
        Next MH   
     Next i

With Sheets("سجل وسط نهاية السنة")
Rng.Font.Size = 11
Rng.Font.Name = "Arial"
Rng.Font.Strikethrough = False

 End With
  
 Range("M3").Select
 Application.ScreenUpdating = True
 
End Sub

وهدا كود لاضافة درجات القرار :

Sub Add_Resolution_2()
Dim i As Long
Dim MH As Long, k As Long
Application.ScreenUpdating = False
With Sheets("سجل وسط نهاية السنة")
lrow = .Cells(Rows.Count, 32).End(xlUp).Row
liste1 = Split("AF,AG,AH,AI,AJ,AK,AL,AM,AN, AO, AP, AQ, AR", ",")
liste2 = Split("D,E,F,G,H,i,j,k,L,M,N,O,P", ",")
For i = LBound(liste1) To UBound(liste1)
.Range(liste1(i) & "6:" & liste1(i) & lrow).Copy Sheets("سجل وسط نهاية السنة").Range(liste2(i) & "6")
Application.ScreenUpdating = True
        Next i
    End With
    End Sub

تراجع_2.xlsm

[saad 77]

السلام عليكم 

اخي واستاذي Mohamed Hicham في المرفق الذي ارفقته في مشاركتي الاولى كود يقوم عند الضغط عليه بالتراجع عن الاجراءات التي كانت موجودة لكنه يتراجع عن جميع الدرجات التي تم تغييرها مااطلبه هو ان يتراجع الكود فقط عن الدرجات المضافة للطالب الراسب فقط لانه في الاساس راسب ولا يجوز اضافة الفرار له

للرفع

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

[محمد هشام.]

يمكنك اخي دالك بجعل الكود بهده الطريقة

Sub Undo_add_change()
Dim Sheet As Worksheet
Dim liste1 As Variant
Dim liste2 As Variant
Dim MH As Long
Dim Rng As Range
Set Sheet = Sheets("سجل وسط نهاية السنة")
Set Rng = Range("D6:L45")
Application.ScreenUpdating = False
For i = 6 To 45
liste1 = Array("49.5 50", "49 50", "48.5 50", "48 50", "47.5 50", "47 50", "46.5 50", "46 50", "45.5 50", "45 50")
liste2 = Array("49.5", "49", "48.5", "48", "47.5", "47", "46.5", "46", "45.5", "45")
         For MH = LBound(liste1) To UBound(liste1)
  If Range("R" & i).Value = "راسب" Then
Range("d" & i, "k" & i).Cells.Replace What:=liste1(MH), Replacement:=liste2(MH), _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, _
                        SearchFormat:=True, ReplaceFormat:=True
Rng.Font.Size = 11
Rng.Font.Name = "Arial"
If Range("R" & i).Value = "راسب" Then
Range("d" & i, "k" & i).Cells.Font.Strikethrough = False
                 End If
          End If
        Next MH
          Next i
 Application.ScreenUpdating = True
 End Sub

تراجع_2.xlsm

[saad 77]

اخي كم انت رائع كم انت لطيف كم انت راقي لا اعرف كيف اشكرك . اسال الله ان يحفظك ويزيدك علما ويسعدك ويرزقك من حيث لاتحتسب ..جزاك الله خيرا 

هناك تكملة وارتباط لهذه المشاركة ولكن  بطلب أخر مختلف على هذا الرابط :

تعديل على كود يوزع درجات القرار من 10