حساب الدرجات اللازمة لنجاح الطالب

[khairi ali]

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

كيف حالكم جميعا في الملف المرفق المطلوب تعديل الكود بحيث يقوم بكتابة مواد الدور الثاني للطالب كما موضح في الصورة 

كود مواد الدور الثاني.xlsm

[ابراهيم الحداد]

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

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

Sub FinalResult()
Const Res = "ناجح ومنقول إلى الصف السابع  بتقدير"
Dim ws As Worksheet
Dim LR As Long, I As Long, x As Integer
Dim Mad As String
t = Timer
Application.ScreenUpdating = False
Set ws = Sheets("ك.د.سد")
On Error Resume Next
ws.Range("F" & I + 3).ClearContents
LR = ws.Range("C" & Rows.Count).End(3).Row
I = 11
Do While I <= LR
If ws.Cells(I, 33) = "ناجح" Then
ws.Cells(I + 3, 6).Value = Res & "" & ws.Cells(I, 29).Value
ElseIf ws.Cells(I, 33) = "له دور ثان في" Then
x = 38
Do While x <= 50
Mad = Mad & "-" & ws.Cells(I, x).Value
ws.Cells(I + 3, 6).Value = ws.Cells(I, 33).Value & " " & Mad
x = x + 2
Loop
End If
Mad = ""
I = I + 4
Loop
Application.ScreenUpdating = True
'MsgBox Round(Timer - t, 2)
End Sub

 

[khairi ali]

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

أخواني الكرام في هذا الصرح التعليمي المتميز كيف حالكم جميعا

أريد كود لكتابة مواد الرسوب وحساب نتيجة الطالب كما موضح في الشيت 

ولكم مني جزيل الشكر والتقدير .... من فضلك لا تقوم بتكرار نفس المشاركات

نتيجة الطالب.xlsb

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub checK_up()
Dim F As Worksheet
Dim Arr(), Itm, My_sum
Dim m%, K%, i%, Ro%, y%
Dim arr_madda()
Dim Res(), XX%, MY_text$
Dim Txt$: Txt = "المجمــــــــــوع"
Set F = Sheets("F1")
Ro = F.Cells(Rows.Count, 3).End(3).Row
If Ro < 12 Then Exit Sub
F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone
F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents
F.Cells(12, "Bx").Resize(Ro - 11).ClearContents
For K = 8 To 55:
 If F.Cells(9, K) = Txt Then
  ReDim Preserve Arr(m): Arr(m) = K:  m = m + 1
  End If
 Next
 m = 0
 For K = 8 To 50
 If F.Cells(6, K) <> "" Then
  ReDim Preserve arr_madda(m): arr_madda(m) = F.Cells(6, K)
  m = m + 1
  End If
 Next
For i = 12 To Ro
      y = 0
       For Each Itm In Arr
               My_sum = My_sum + F.Cells(i, Itm)
             If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then
               F.Cells(i, Itm).Interior.ColorIndex = 6
               ReDim Preserve Res(y)
               Select Case Itm
                  Case Is <= 13: Res(y) = arr_madda(0)
                  Case Is <= 20: Res(y) = arr_madda(1)
                  Case Is <= 27: Res(y) = arr_madda(2)
                  Case Is <= 34: Res(y) = arr_madda(3)
                  Case Is <= 41: Res(y) = arr_madda(4)
                  Case Is <= 48: Res(y) = arr_madda(5)
                  Case Is <= 55: Res(y) = arr_madda(6)
               End Select
               y = y + 1
            End If
      Next Itm
              If y > 1 Then
                F.Cells(i, "Ca").Resize(, y) = Res
              Else
                F.Cells(i, "Bx") = My_sum
              End If
          Erase Res: y = 0: My_sum = 0
Next i
 
End Sub

الملف مرفق

Khiri_ali.xlsm

[khairi ali]

السلام عليكم أستاذ سليم 

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

ولم يقوم بحساب النسبة 

[سليم حاصبيا]

انت وضعت 7 أعمدة لمواد الرسوب من  العامود 79  الى  العامود 85 (ممكن ان بكون عدد هذه المواد اكثر)
لذلك وضعت انا  اعمدة زيادة (خاصة انه لكل مادة اكثر من فصل واحد)

اما ترتيب المواد  ذلك يكون حسب  ورودها في الجدول (اذا كانت اول مادة رسوب للطالب (فلان) هي الرياضيات مثلاً فانك تجدها الأولى في الجدول (في الصف) الذي يخصه

النسبة لم اتدخل بها لانها مجرد معادلة بسيطة

[سليم حاصبيا]

با اخي 7 مواد  ضرب 2 فصول   يعني 14  نتيجة يعني 14  عامود  (انت تريد تنيجة لكل فضل من الفصول)

[khairi ali]

اقصد نتيجة الفصل الاول تعطى في منتصف السنة اما الفصل الثاني فتعطى نهاية العام

[سليم حاصبيا]

تم التعديل كما تريد
1-تحنار الفضل من الخلية  Bx6  ثم تضغط على الزر  Fasl
2- الماكرو القديم ما زال يعمل (للفصلين معاً ) الزر ALL

الماكرو الجديد

Option Explicit


Sub checK_up_By_Fasl()
Dim F As Worksheet
Dim Arr(), Itm, My_sum
Dim m%, K%, i%, Ro%, y%
Dim arr_madda()
 Const a = 4
 Const b = 1
 Dim Nb%
Dim Res(), XX%, MY_text$
Dim Txt$: Txt = "المجمــــــوع الكلـــــــي"
Set F = Sheets("F1")
Ro = F.Cells(Rows.Count, 3).End(3).Row
If Ro < 12 Then Exit Sub
F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone
F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents
F.Cells(12, "Bx").Resize(Ro - 11).ClearContents
Select Case F.Range("Bx6")
 Case "الأول": Nb = a
 Case "الثاني": Nb = b
End Select
For K = 8 To 55
 If F.Cells(7, K) = Txt Then
  ReDim Preserve Arr(m): Arr(m) = K - Nb: m = m + 1
  End If
 Next
 m = 0
 For K = 8 To 50
 If F.Cells(6, K) <> "" Then
  ReDim Preserve arr_madda(m)
  arr_madda(m) = F.Cells(6, K) & " / " & F.Range("Bx6")
  m = m + 1
  End If
 Next
For i = 12 To Ro
      y = 0
       For Each Itm In Arr
               My_sum = My_sum + F.Cells(i, Itm)
             If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then
               F.Cells(i, Itm).Interior.ColorIndex = 6
               ReDim Preserve Res(y)
               Select Case Itm
                  Case Is <= 13: Res(y) = arr_madda(0)
                  Case Is <= 20: Res(y) = arr_madda(1)
                  Case Is <= 27: Res(y) = arr_madda(2)
                  Case Is <= 34: Res(y) = arr_madda(3)
                  Case Is <= 41: Res(y) = arr_madda(4)
                  Case Is <= 48: Res(y) = arr_madda(5)
                  Case Is <= 55: Res(y) = arr_madda(6)
               End Select
               y = y + 1
            End If
      Next Itm
              If y > 1 Then
                F.Cells(i, "Ca").Resize(, y) = Res
              Else
                F.Cells(i, "Bx") = My_sum
              End If
          Erase Res: y = 0: My_sum = 0
Next i
 
End Sub

الملف من جديد

Khiri_ali_New.xlsm

[khairi ali]

بارك الله فيك استاذي الفاضل وان شاء الله في ميزان حسناتك

أستاذ سليم  لو سمحت أريد الجمع يكون في العمود bn  وهناك مشكلة في الكود عند أختيار الأول و الضغظ على fasl  لاحظ الطالب رقم 1 راسب في مادة التربية الاسلامية ولم يقوم بوضع أسم المادة في المكان المحدد .

[سليم حاصبيا]

عندي كل شيء على ما يرام (الصورة  توضح ذلك)

لتغيير عامود الجمع استبدل   Bx  بــــــ     BN   (الصورة الثاتية)

[khairi ali]

لأخوة الأفاضل: السلام عليكم ورحمة الله وبركاته

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

الدرجات اللازمة لنجاح الطالب.xlsm

[سليم حاصبيا]

علمتني التجارب بعدم العمل مع  اي جدول يحتوي عل خلايا مدمجة