اذهب الي المحتوي
أوفيسنا

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى

ناصر سعيد

بواسطه ناصر سعيد
في منتدى الاكسيل Excel

 مشاركة

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

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى

شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى  وهما العالم العلامه والبحر الفهامه عبد الله باقشير

ومعه العبقري ذو الخلق الحسن ياسر العربي - جزاهم الله كل خير -

في كود لكل منهما يستطيع كود كل واحد منهم ان يستخرج الطلاب الناجحين وطلاب الدور التاني بسلاسه

اولا : هذا كود العلامه عبد الله باقشير  حفظه الله .. بشرح اسطر الكود 

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر (معدل)

كود آخر لنفس الموضوع وللعلامه عبد الله باقشير

وهذا رابطه

  

LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

Dim MyBoolean As Boolean
Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       Kh_DeletShape
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
On Error Resume Next
Dim MyRng_All As Range, c As Range
Dim V As Shape, S As String
Dim K As Integer, x As Integer, d As Long, N As Integer, y As Integer
Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer
Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer
'================================================
عمود_رقم_الجلوس = 2
صف_الدرجات = 12
صف_مواد_دور_ثاني = 8
عمود_حالة_الطالب = 51
عمود_المواد = 52
   y = Sheets("بيانات المدرسة").Range("B10").Value + 12
   Set MyRng_All = Range("p13", Cells(y, 51)) ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
x = ActiveWindow.Zoom
Application.ScreenUpdating = False


LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

ActiveWindow.Zoom = 100
For Each c In MyRng_All
    K = c.Column
    If Cells(c.Row, عمود_رقم_الجلوس) = 0 Then GoTo 3
    If Cells(صف_مواد_دور_ثاني, c.Column) <> "م" Then
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or c.Value = "غ" Or c.Value = "غـ") Then
            If MyBoolean Then GoTo 1
            Kh_AddShape c, V
            d = d + 1
        End If
1
    Else
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or Cells(c.Row, c.Column - 1) < Cells(صف_الدرجات, c.Column - 1) Or Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ") Then
            If Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ" Then N = N + 1
            '================================================
'           ترحيل مواد دورثاني ان وجدت
            If Cells(c.Row, عمود_المواد) = "" Then S = "" Else S = " - "
            Cells(c.Row, عمود_المواد) = Cells(c.Row, عمود_المواد) & S & Cells(صف_مواد_دور_ثاني - 1, c.Column)
            '================================================
            If MyBoolean Then GoTo 2
            Kh_AddShape c, V
            d = d + 1
        End If
    End If
   '================================================
'           ترحيل حالة الطالب
2
    If K = MyRng_All.Columns.Count + MyRng_All.Column - 1 Then
        If N = 4 Then Cells(c.Row, عمود_حالة_الطالب) = "غائب": Cells(c.Row, عمود_المواد) = "جميع المواد" _
        Else If Cells(c.Row, عمود_المواد) = "" Then Cells(c.Row, عمود_حالة_الطالب) = "ناجح ومنقول للصف الثالث" Else Cells(c.Row, عمود_حالة_الطالب) = "له دور ثاني في"
        N = 0
    End If
   '================================================
3 Next
ActiveWindow.Zoom = x
Application.ScreenUpdating = True
If MyBoolean Then GoTo 4
MsgBox "تم إضافة   " & d & "   دائرة بنجاح" & Chr(10) & Chr(10) & "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
On Error GoTo 0
4 End Sub
Sub Kh_AddShape(MyCell As Range, Kh_shp As Shape)
    Set Kh_shp = ActiveSheet.Shapes.AddShape(msoShapeOval, MyCell.Left, MyCell.Top, MyCell.Width, MyCell.Height)
    With Kh_shp
        .Fill.Visible = msoFalse
        .Line.ForeColor.SchemeColor = 10
        .Line.Weight = 2.25
    End With
End Sub
Sub Kh_DeletShape()
    Dim myshape As Shape, d As Long
    For Each myshape In ActiveSheet.Shapes
      If myshape.Type = 1 Then myshape.Delete: d = d + 1
    Next myshape
MsgBox "تم حذف   " & d & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub
Sub تحديث()
MyBoolean = True
Circles1
MyBoolean = False
MsgBox "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
End Sub

 

تم تعديل بواسطه ناصر سعيد
التنسيق
  • Thanks 1
رابط هذا التعليق
شارك
ياسر العربى

ياسر العربى

قام بنشر
قام بنشر

اخي الكريم ناصر مشكور على هذه اللفته الطيبة وما نحن الا طلاب بجانب عمالقة المنتدى الكرام مثل ا /عبد الله باقشير

وما قمت بعمله هو تعديل بسيط بداخل الكود ليتوافق مع ما تم طلبه

اما الكود الخاص بي فهو يعتمد اعتماد كلي على المعادلات بالشيت رقم 3 هو ممكن يكون بطئ بعض الشئ الا انه يتميز بالمرونة امام كل من يستخدم المعادلات ولا يعرف الكثير

عن الVBA

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

والكود ما هو الا ناقل لنتائج المعادلات الى جانب كل طالب

تقبل فائق احترامي وتقديري

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر

وهذا هو الكود الاخر للعلامه عبد الله باقشير 

LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

Dim MyBoolean As Boolean
Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       Kh_DeletShape
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
On Error Resume Next
Dim MyRng_All As Range, c As Range
Dim V As Shape, S As String
Dim K As Integer, x As Integer, d As Long, N As Integer, y As Integer
Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer
Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer
'================================================
عمود_رقم_الجلوس = 2
صف_الدرجات = 12
صف_مواد_دور_ثاني = 8
عمود_حالة_الطالب = 51
عمود_المواد = 52
   y = Sheets("بيانات المدرسة").Range("B10").Value + 12
   Set MyRng_All = Range("p13", Cells(y, 51)) ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
x = ActiveWindow.Zoom
Application.ScreenUpdating = False


LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12
Range("AY13:AZ" & LastRow_1).ClearContents

ActiveWindow.Zoom = 100
For Each c In MyRng_All
    K = c.Column
    If Cells(c.Row, عمود_رقم_الجلوس) = 0 Then GoTo 3
    If Cells(صف_مواد_دور_ثاني, c.Column) <> "م" Then
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or c.Value = "غ" Or c.Value = "غـ") Then
            If MyBoolean Then GoTo 1
            Kh_AddShape c, V
            d = d + 1
        End If
1
    Else
        If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _
            And (c.Value < Cells(صف_الدرجات, c.Column) Or Cells(c.Row, c.Column - 1) < Cells(صف_الدرجات, c.Column - 1) Or Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ") Then
            If Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ" Then N = N + 1
            '================================================
'           ترحيل مواد دورثاني ان وجدت
            If Cells(c.Row, عمود_المواد) = "" Then S = "" Else S = " - "
            Cells(c.Row, عمود_المواد) = Cells(c.Row, عمود_المواد) & S & Cells(صف_مواد_دور_ثاني - 1, c.Column)
            '================================================
            If MyBoolean Then GoTo 2
            Kh_AddShape c, V
            d = d + 1
        End If
    End If
   '================================================
'           ترحيل حالة الطالب
2
    If K = MyRng_All.Columns.Count + MyRng_All.Column - 1 Then
        If N = 4 Then Cells(c.Row, عمود_حالة_الطالب) = "غائب": Cells(c.Row, عمود_المواد) = "جميع المواد" _
        Else If Cells(c.Row, عمود_المواد) = "" Then Cells(c.Row, عمود_حالة_الطالب) = "ناجح ومنقول للصف الثالث" Else Cells(c.Row, عمود_حالة_الطالب) = "له دور ثاني في"
        N = 0
    End If
   '================================================
3 Next
ActiveWindow.Zoom = x
Application.ScreenUpdating = True
If MyBoolean Then GoTo 4
MsgBox "تم إضافة   " & d & "   دائرة بنجاح" & Chr(10) & Chr(10) & "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
On Error GoTo 0
4 End Sub
Sub Kh_AddShape(MyCell As Range, Kh_shp As Shape)
    Set Kh_shp = ActiveSheet.Shapes.AddShape(msoShapeOval, MyCell.Left, MyCell.Top, MyCell.Width, MyCell.Height)
    With Kh_shp
        .Fill.Visible = msoFalse
        .Line.ForeColor.SchemeColor = 10
        .Line.Weight = 2.25
    End With
End Sub
Sub Kh_DeletShape()
    Dim myshape As Shape, d As Long
    For Each myshape In ActiveSheet.Shapes
      If myshape.Type = 1 Then myshape.Delete: d = d + 1
    Next myshape
MsgBox "تم حذف   " & d & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub
Sub تحديث()
MyBoolean = True
Circles1
MyBoolean = False
MsgBox "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله"
End Sub

 

http://www.officena.net/ib/applications/core/interface/file/attachment.php?id=113355

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept