بسم الله الرحمن الرحيم
اليوم نقدم لكم كود للتسهيل على الاخوة العاملين بالتربية والتعليم
وهو كود لاستخراج حالة الطالب
ناجح او دور ثان اضافة لذلك مواد الرسوب
الكود يحتاج الى تحديد الثوابت الموجودة بالكود
وتم توضيح مكان التعديلات بالكود حسب توزيعات الملف
الكود
Sub YASSER_ELARABY()
'YASSER_ELARABY
'26-9-2016
Dim ARR
Dim ARRY
Dim ARRYS
Dim ALL_LESS As String
Const STATUS As Byte = 101 'عمود الحالة ناجح او دور ثان
Const NOTES As Byte = 102 ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
Const GENDER As Byte = 112 ' عمود الجنس ذكر او انثى
'_____________________________________________________
Const LESS_ROW As Byte = 6 'صف الدرجة الصغرى
Const NAM_ROW As Byte = 2 'صف اسماء المواد
Const NAME_FIRST As Byte = 7 ' اول صف لاسماء الطلاب
Const NAME_LAST As Long = 206 + NAME_FIRST ' عدد الطلاب
'_____________________________________________________
ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78) ' اعمدة اختبار الفصل الدارسي الثاني لجميع المواد
ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82) 'اعمدة الدرجة النهائية لجميع المواد
ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74) 'اعمدة اسماء كل المواد
'_____________________________________________________
With Sheet2 'اسم الشيت الموجود به البيانات
For R = NAME_FIRST To NAME_LAST
For X = 0 To UBound(ARR)
On Error Resume Next
Application.ScreenUpdating = False
If ARR(X) = 46 Then
If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then
ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
GoTo 86
Else
GoTo 86
End If
End If
If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" _
Or .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
End If
86 Next X
'_____________________________________________________
If ALL_LESS = "" Then
If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح "
If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة "
If .Cells(R, GENDER) = 1 Then .Cells(R, 102) = "ومنقول " & INFO.Range("B14")
If .Cells(R, GENDER) = 2 Then .Cells(R, 102) = "ومنقولة " & INFO.Range("B14")
ElseIf ALL_LESS <> "" Then
If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في"
If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في"
.Cells(R, 102) = Left(ALL_LESS, Len(ALL_LESS) - 2)
ALL_LESS = Empty
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
كما هو موضح اماكن التعديل بالكود
لتحميل الملف اضغط هنا
التعديل يشمل الرسوب باقل من ثلث الدرجة للفصل الدراسي الثاني
الكود
لتحميل الملف اضغط هنا
لتحميل الملف اضغط هنا
تعديل اخر للكود ليتماشى مع نظام المدارس اكثر
التعديل يشمل الرسوب باقل من ثلث الدرجة للفصل الدراسي الثاني
واذا تغيب الطالب في كل المواد او مجموع كل المواد صفر يصبح الطالب غائب
الكود
Sub YASSER_ELARABY()
'YASSER_ELARABY
Dim ARR
Dim ARRY
Dim ARRYS
'___________________________________________
Dim R As Long
Dim X As Long
Dim XX As Byte
Dim ALL_LESS As String
'___________________________________________
Const STATUS As Byte = 101 'عمود الحالة ناجح او دور ثان
Const NOTES As Byte = 102 ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
Const GENDER As Byte = 112 ' عمود الجنس ذكر او انثى
'_____________________________________________________
Const LESS_ROW As Byte = 6 'صف الدرجة الصغرى
Const NAM_ROW As Byte = 2 'صف اسماء المواد
Const NAME_FIRST As Byte = 7 ' اول صف لاسماء الطلاب
Const NAME_LAST As Long = 206 + NAME_FIRST ' عدد الطلاب
'_____________________________________________________
ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78) ' اعمدة اختبار الفصل الدارسي الثاني لجميع المواد
ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82) 'اعمدة الدرجة النهائية لجميع المواد
ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74) 'اعمدة اسماء كل المواد
'_____________________________________________________
With Sheet2 'اسم شيت البيانات
Application.ScreenUpdating = False 'الغاء تحديث الشاشة
Application.Calculation = xlManual ' ايقاف الحساب التلقائي
For R = NAME_FIRST To NAME_LAST ' حلقة تكرارية تبدأ بأول اسم طالب الى اخر اسم
For X = 0 To UBound(ARR) ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني
On Error Resume Next
'____________________________________________________
'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس
'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب
If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then
XX = XX + 1
End If
'____________________________________________________
'هذا الجزء خاص بمادة العلوم تحديدا الفصل الدراسي الثاني لانه مقسم على عمودين فتم اضافة هذا الجزء ليتم معالجة هذه المرحلة
If ARR(X) = 46 Then
'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل
If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then
ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86
GoTo 86 'هنا يتم تخطى عمل الكود بالاسفل حتى لايتم معالجة مادة العلوم مرة اخرى
Else
GoTo 86 'وهنا ايضا يتم تخطى مادة العلوم الى المادة الاخرى
End If
End If
'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف المواد الى المتغير
'ALL_LESS
'او مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير
'ALL_LESS
'______________________________________________________
If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then
ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86
End If
If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
End If
'______________________________________________________
86 Next X 'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد
'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب
If XX = 11 Then ALL_LESS = "غياب ": XX = 0
'_____________________________________________________
'هنا بعد اكتمال الكود يتم عمل شرط للمتغير
'ALL_LESS
'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح
If ALL_LESS = "" Then
If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح " 'اذا كان نوع الطالب ذكر يتم وضع ناجح
If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة " 'اذا كانت انثى يتم وضع ناجحه
If .Cells(R, GENDER) = 1 Then .Cells(R, NOTES) = "ومنقول " & INFO.Range("B14") 'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو
If .Cells(R, GENDER) = 2 Then .Cells(R, NOTES) = "ومنقولة " & INFO.Range("B14") 'مثل ماسبق
'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان
ElseIf ALL_LESS <> "" Then
If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في" 'مثل ما سبق بخصوص النوع
If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في" '
.Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2) 'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات
ALL_LESS = Empty 'تفريغ المتغير لاعادة تعبئة اسم طالب اخر
End If
'_____________________________________________________
Next R 'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب
End With
Application.ScreenUpdating = True 'اعادة تحديث الشاشة
Application.Calculation = xlAutomatic 'تشغيل الحساب التلقائي
End Sub
لتحميل الملف اضغط هنا
اعداد / ياسر العربي
الإبتساماتإخفاء