البحث في الموقع

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى وهما العالم العلامه والبحر الفهامه عبد الله باقشير ومعه العبقري ذو الخلق الحسن ياسر العربي - جزاهم الله كل خير - في كود لكل منهما يستطيع كود كل واحد منهم ان يستخرج الطلاب الناجحين وطلاب الدور التاني بسلاسه اولا : هذا كود العلامه عبد الله باقشير حفظه الله .. بشرح اسطر الكود Option Explicit ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير ''الهدف من الكود ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''وقد تمت اضافة جزئيه حسب المتطلبات الجديده للمدارس ''بفضل الله اولا ثم العبقري ياسر العربي ' اسماء المواد Const nTEST As String = "عربي" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "رسم" & "," & _ "العاب" & "," & _ "نشاط1" & "," & _ "نشاط 2" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء الموادوعددها Const ColmnTotal As String = "13,22,31,40,51,57,54,59,64,69,82" ' ارقام اعمدة الفصل الثاني 'ويجب ان يتساوى عددها 'مع عدد اسماء المواد 'لعليا التي كتبت ' وهنا المجموع ً Const ColmnTest2 As String = "9,18,27,36,47,54,57,62,67,72,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 6 ' اول صف للبيانات Const TopRow As Integer = 7 Sub kh_Tgrba() Dim sCont As Integer, R As Integer Dim Tst As String Dim xx As String Dim xxx As String Dim go As String Dim Arr, i, x On Error GoTo 0 '------------------ ' عدد الطلبة ' ممكن يؤخذ من خلية او يكتب كتابة sCont = Sheets("بيانات المدرسة").Range("B10").Value '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------ sCont = sCont + TopRow With ActiveSheet For R = TopRow To sCont If Not IsEmpty(.Cells(R, "C")) Then Tst = kh_Test(R) '''الاضافه هنا '--متغير اســم ورقم العمود '_ما تم التعديل عليه هذه الجزئية تم اضافة عليها بعض الاسطر Select Case .Cells(R, 112) 'لتحديد النوع للطالب Case 1: xx = "له دور ثان في": xxx = "ناجح": go = "ومنقول " & Sheets("بيانات المدرسة").Range("b16") Case 2: xx = "لها دور ثان في": xxx = "ناجحه": go = "ومنقوله " & Sheets("بيانات المدرسة").Range("b16") End Select If Len(Tst) Then .Cells(R, "CW") = xx Else .Cells(R, 101) = xxx '--متغير اسم العمود 'عمود ملاحظات المواد .Cells(R, "CX") = kh_Test(R) '--متغير رقم العمود 'عمود رقم النتيجة Select Case .Cells(R, 101) '--متغير اسم العمود 'اذا كان الطالب ناجح او ناجحةاذن يتم اعتماده منقول او منقوله للصف التالي Case xxx: .Cells(R, "CX") = go End Select x = 0 ''مصفوفة باسماء خلاياالمواد ''متغير أسماء اعمدة اختبار الترم التاني Arr = Array(.Range("i" & R), .Range("r" & R), .Range("aa" & R), .Range("aj" & R), .Range("at" & R), .Range("au" & R), .Range("bb" & R), .Range("bg" & R), .Range("bl" & R), .Range("bq" & R), .Range("bz" & R)) ' حلقة تكرارية للبحث داخل المصفوقة عن الغائب اذا وجد يتم اضافته للمتغير اكس For Each i In Arr Select Case i Case "غ": x = x + 1 End Select Next 'اذا كان المتغير اكس يساوي عدد جميع مواد الترم الثاني اذن هو غائب Select Case x Case 11: .Cells(R, "CX") = "غياب" End Select 'الشرط الثاني اذا كان المجموع يساوي صفر اذن غائب Select Case .Cells(R, 52) Case 0: .Cells(R, "CX") = "غياب" End Select 'اذا كان الطالب باق بشرط ان كون في الصف الاول او الثاني يصبح ناجح بحكم القانون If .Cells(R, 111) = "باق" And (Sheets("بيانات المدرسة").Range("b12") = 1 Or Sheets("بيانات المدرسة").Range("b12") = 2) Then: .Cells(R, "CX") = go & " بحكم القانون": .Cells(R, "Cw") = xxx '____________________________________________ End If Next End With 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم اظهار النتيجة بنجاح" End If End Sub Function kh_Test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, CC As Integer Dim ib As Boolean CC = UBound(Split(nTEST, ",")) For c = 0 To CC ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ", "غـ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ", "غـ" NN = NN & " لثلث الدرجة": ib = True Case Is < Cells(iRs, ctst) NN = NN & " لثلث الدرجة": ib = True End Select End If 1: If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN Next kh_Test = TT End Function استخراج حاله الطالب للعلامه عبد الله باقشير.rar اولا : هذا كود العبقري ياسر العربي حفظه الله .. بشرح اسطر الكود Sub Yasser() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''شرح الكود '' 3 متغيرات Dim LR As Integer, _ LR1 As Integer, _ T As Integer ''صف البدايه T = 7 ''متغير اسم شيت الرصد With Sheets(1) ''موقع رقم الجلوس LR1 = .Cells(7, 2) '' متغير اسم شيت الجدول ' هنا يتم جلب اول رقم الجلوس الى شيت المعادلات للعمل عليه Sheet3.Range("c6") = LR1 'متغير لمعرفة اخر صف به بيانات LR = .Cells(.Rows.Count, 1).End(xlUp).Row ''المدى المطلوب مسحه لكتابة حاله الطالب فيه Range("cw7:cx" & LR).ClearContents 'حلقة تكرارية من اول طالب الى اخر طالب For R = 7 To LR 'اذا كانت قيمة حرف التيي اكبر من او يساوي اخر طالب يذهب خارج الحلقة التكرارية الى السطر صفر If T - 1 >= LR Then GoTo 0 Else 'ايقاف تحديث الشاشة Application.ScreenUpdating = False 'هنا يتم تطبيق كود اكس اكس الخاص بوضع الفواصل بين المواد xxx ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 101) = Sheet3.Cells(2, 9) ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 102) = Sheet3.Cells(2, 10) 'هنا قيمة الخلية المذكورة الخاصة برقم جلوس ' الطالب تساوي نفسها +1 للذهاب الى الطالب التالي لتطبيق الكود مره اخرى Sheet3.Range("c6").Value = Sheet3.Range("c6").Value + 1 'وهنا بالمثل نضيف واحد الى هذا المتغير للنزول الى الصف التالي وهكذا حتى تنتهي البيانات T = T + 1 End If Next End With '' متغير اسم شيت الجدول وموقع الخليه 0 Sheet3.Range("c6") = LR1 'اعادة تحديث الشاشة Application.ScreenUpdating = True MsgBox "تم بحمد الله" End Sub ''-------------------------------------------------------- Sub xxx() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 '' هذف الكود هو وضع شرطه بين مواد الدور التاني ''شرح الكود With Sheet3 Dim Rng As Range 'حلقة تكرارية لصف المواد التى لها دور ثان For Each Rng In .Range("d10:n10") 'اذا كانت الخلية بها بيانات اذن يتم تطبيق التالي If Rng <> "" Then 'ضع المادة بالخلية الموضحه .Range("j11") = .Range("j11") & Rng 'وضع الشرطة بعد كل مادة .Range("j11") = .Range("j11") & " -" End If Next Rng 'بعد الانتهاء من وضع كل الفواصل تظل شرطة اخيرة يتم حذفها بهذه الطريقة .Range("J12").FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-1)" .Range("J12") = .Range("J12").Value .Range("j11").ClearContents End With End Sub حفظ الله كل من ساهم في اخراج هذا العمل المتميز استخراج حاله الطالب للعبقري ياسر العربي.rar