تعديل كود تحدبث حالة الطالب

[ناصر سعيد]

ربنا يبارك لك استاذ ابو عبد الباري

[ابو عبدالبارى]

في ٤‏/٦‏/٢٠١٦ at 11:02, ناصر سعيد said:

جزاك الله كل خير وبارك لك استاذ ابو عبد الباري

لو تكرمت شرحك مفهوم .. ولكن نقطه المجموع  كيف تم حلها ؟

ممكن بفكرتك المفيده  والرائعه في نقليل عدد الطلاب فزادت سرعه الكود .. هل يمكن اضافه ان هذا العدد يساوي عدد طلاب الصف  الموجود بالصفحه الرئيسيه ... يدل ال 1000

اخى العزيز/ ناصر سعيد

شكرا لكلماتك الرقيقة اما بالنسبة للمطلوب غى المرفق التالى

 

تعديل مواد الصف الثاني.rar

[ناصر سعيد]

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
Range("ay13", Cells(y, 52)).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

هذا افضل تعديل للمحترم ابو عبد الباري اعزه الله وجزاه عنا كل خير

وبعد

 عمود اختبار الترم التاني الموجود الآن قبل الدرجه الكليه مباشره

طيب لو هذا العمود اختبار الترم التاني قبل الدرجه الكليه ب  4   اعمده مثلا

ماهو الحل .. اين مواقع التغيير من فضلك

 

تم تعديل يونيو 5, 2016 بواسطه ناصر سعيد
تكبير الخط

[علي فاهم]

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.kuwaiti.co/l6ix9221b464

[ابو عبدالبارى]

اخى العزيز / ناصر سعيد

بدلا عن -1 اكتب -4

 

  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

[ناصر سعيد]

الاستاذ المحترم ابو عبد الباري

ربنا يبارك لك
 

[ابو عبدالبارى]

4 ساعات مضت, جلال محمد said:

اخي ابو عبد الباري

رمضان كريم 

المواد بعد المجموع الكلي مثلها مثل باقي المواد قبل المجموع الكلي جرب ان تجعل طالب راسب في احداها وشاهد .... جرب في الملف المرفق في الرابط

ملفك جميل .... وانشاء الله سأحاول استفيد منه وخصوصا في حالة الطالب المعفي لأني تعرضت لها هذا العام 

ورمضان كريم .... وكل عام وانت وجميع المسلمين بخير

اسف رابط الملف

http://www.kuwaiti.co/l6ix9221b464

اخى العزيز / جلال محمد

السلام عليكم ورمضان كريم

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

Set MyRng_All = Range("p13:by2000")  ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ
'================================================
x = ActiveWindow.Zoom
Application.ScreenUpdating = False
Range("bz13:ca2000").ClearContents

اليس كذلك وعذرا على السؤال

ورمضلن كريم عليك وعلى كل الأخوة بالمنتدى

5 دقائق مضت, ناصر سعيد said:

الاستاذ المحترم ابو عبد الباري

ربنا يبارك لك
 

وبارك لنا فيك وفى كل الأخوة بالمنتدى ورمضان كريم

[جلال محمد]

اقتباس

بارفاقك الملف الأصلى فى آخر مشاركة فانه يظهر مابعد المجموع الكلى لتغيير النطاق به

فعلا استاذ ابو عبد الباري 

[ابو عبدالبارى]

اخى الكريم جلال محمد

تم الوصول لحل لمشكلتك فى الملف المرفق اذا اعجبك الحل فضلا منك شارك به فى موضوع جديد ليستفيد منه اعضاء المنتدى الكريم وكل عام وانتم بخير .........

http://www.mediafire.com/download/lk5h2r5v81430nz/العلمي_جديد.rar

[ناصر سعيد]

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

تجربه1.rar

[ناصر سعيد]

الكود سليم وعند نقله في هذا الملف لايعمل

[جلال محمد]

اخي   ابو عبد الباري

السلام عليكم 

جزاك الله خيرا علي مجهودك العظيم 

ولكن اريد منك شرح الأجزاء التي بها تعديل .... كما في الصورة المرفقة

 

[ابو عبدالبارى]

6 ساعات مضت, جلال محمد said:

اخي   ابو عبد الباري

السلام عليكم 

جزاك الله خيرا علي مجهودك العظيم 

ولكن اريد منك شرح الأجزاء التي بها تعديل .... كما في الصورة المرفقة

 

اخى الكريم جلال محمد

تم استخدام المتغير y لحساب عدد الصفوف االموجود بها الطلبة حتى لا يتأخر تنفيذ الماكرو كما طلب الأستاذ / ناصر سعيد

[جلال محمد]

اخي   ابو عبد الباري

السلام عليكم 

اقتباس

تم استخدام المتغير y لحساب عدد الصفوف االموجود بها الطلبة حتى لا يتأخر تنفيذ الماكرو كما طلب الأستاذ / ناصر سعيد

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

ولي سؤال عن الرقم المشار الية في الصورة المرفقة ..... علام يدل الرقم +12 

[ابو عبدالبارى]

اخى الكريم جلال محمد

 

بالنسبة الى +12 اى يبدأ عد الصفوف التى بها طلبة من الصف 12 وذلك كما ذكرت لتسريع الكود أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر

[ناصر سعيد]

24 دقائق مضت, ابو عبدالبارى said:

اخى الكريم جلال محمد

 أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر

الاستاذ ابو عبد الباري

جزاك الله خيرا .. زدني فهما لهذه الجزئيه كرما منك

[جلال محمد]

اخي   ابو عبد الباري

اقتباس

 أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر

اي جزء احمر 

هل تقصد هذا 

ام تقصد هذا 

فانا اعلم  ان الجزء الأول خاص بتحديد مجال التحديث

والجزء الثاني لتحديد عمود حالة الطالب ومواد الدور الثاني 

تم تعديل يونيو 11, 2016 بواسطه جلال محمد

[ابو عبدالبارى]

  Set MyRng_All = Range("p13", Cells(Y, 95))

حل المشكلة فى هذه الجزئية

[جلال محمد]

اخي   ابو عبد الباري

كدة وضحت الفكرة ...... الحل رائع ... وعبقري 

جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك 

شكرا لك .

[ابو عبدالبارى]

منذ ساعه, جلال محمد said:

اخي   ابو عبد الباري

كدة وضحت الفكرة ...... الحل رائع ... وعبقري 

جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك 

شكرا لك .

اخى الكريم جلال محمد

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

بارك الله فيك وشكرا لكلماتك الجميلة و رمضان كريم

 

[ناصر سعيد]

1 ساعه مضت, جلال محمد said:

اخي   ابو عبد الباري

كدة وضحت الفكرة ...... الحل رائع ... وعبقري 

جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك 

شكرا لك .

ارجو كما وضحت الفكره لك وضحها اكثر لنا جزاك الله خيرا

[ناصر سعيد]

23 ساعات مضت, ابو عبدالبارى said:

Set MyRng_All = Range("p13", Cells(Y, 95))

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

[جلال محمد]

اخي ناصر 

السلام عليكم 

اقتباس

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

فعلا اخي ناصر تم نقل او تكرار عمود المجموع الكلي الي العمود 95 .... وبهذا تم حل مشكلة ربع الدرجة بالنسبة لعمود المجموع .... لأن الكود عندما يقوم بمقارنة عمود المجموع بعمود ربع الدرجة يجدة فارغ .... بشرط حزف حرف ( م ) من عمود المجموع الأصلي ...... الحل رائع وبسيط ..... جزي الله الأستاذ ابو عبد الباري خيرا ..... وشكرا للجميع ..... ورمضان كريم