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

khairi ali · يناير 23, 2021

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

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

**ابراهيم الحداد** · يناير 24, 2021

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

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

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 · فبراير 2, 2021

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

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

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

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

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

**سليم حاصبيا** · فبراير 2, 2021

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

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 · فبراير 2, 2021

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

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

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

**سليم حاصبيا** · فبراير 2, 2021

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

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

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

**سليم حاصبيا** · فبراير 2, 2021

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

khairi ali · فبراير 2, 2021

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

**سليم حاصبيا** · فبراير 2, 2021

تم التعديل كما تريد
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 · فبراير 3, 2021

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

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

**سليم حاصبيا** · فبراير 3, 2021

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

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

khairi ali · فبراير 12, 2021

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

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

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

**سليم حاصبيا** · فبراير 12, 2021

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

تسجيل الدخول

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

الردود الموصى بها

khairi ali

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

khairi ali

سليم حاصبيا

khairi ali

سليم حاصبيا

سليم حاصبيا

khairi ali

سليم حاصبيا

khairi ali

سليم حاصبيا

khairi ali

سليم حاصبيا

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information