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

**ناصر سعيد** · يونيو 5, 2016

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

**ابو عبدالبارى** · يونيو 5, 2016

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

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

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

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

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

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

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

**ناصر سعيد** · يونيو 5, 2016

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 بواسطه ناصر سعيد
تكبير الخط

علي فاهم · يونيو 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

تمت هذه الاضافه

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

**جلال محمد** · يونيو 6, 2016

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

رمضان كريم

اقتباس

المواد ما بعد المجموع الكلى ماذا لو رسب اى طالب بها لن تظهر فى مواد الرسوب لأنى لاحظت (انة لا يوجد طالب راسب فى هذه المواد )

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

اقتباس

اما بالنسبة لملفى انا قمت برفعه لأبداء الملاحظات علية

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

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

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

http://www.kuwaiti.co/l6ix9221b464

**ابو عبدالبارى** · يونيو 6, 2016

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

بدلا عن -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

**ناصر سعيد** · يونيو 6, 2016

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

ربنا يبارك لك

**ابو عبدالبارى** · يونيو 6, 2016

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:

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

ربنا يبارك لك

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

**جلال محمد** · يونيو 7, 2016

اقتباس

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

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

**ابو عبدالبارى** · يونيو 7, 2016

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

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

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

**ناصر سعيد** · يونيو 8, 2016

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

تجربه1.rar

**ناصر سعيد** · يونيو 9, 2016

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

**جلال محمد** · يونيو 9, 2016

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

السلام عليكم

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

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

**ابو عبدالبارى** · يونيو 9, 2016

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

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

السلام عليكم

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

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

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

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

**جلال محمد** · يونيو 10, 2016

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

السلام عليكم

اقتباس

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

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

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

**ابو عبدالبارى** · يونيو 11, 2016

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

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

**ناصر سعيد** · يونيو 11, 2016

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

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

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

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

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

**جلال محمد** · يونيو 11, 2016

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

اقتباس

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

اي جزء احمر

هل تقصد هذا

ام تقصد هذا

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

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

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

**ابو عبدالبارى** · يونيو 11, 2016

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

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

**جلال محمد** · يونيو 11, 2016

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

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

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

شكرا لك .

**ابو عبدالبارى** · يونيو 11, 2016

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

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

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

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

شكرا لك .

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

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

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

**ناصر سعيد** · يونيو 11, 2016

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

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

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

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

شكرا لك .

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

**ناصر سعيد** · يونيو 12, 2016

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

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

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

**جلال محمد** · يونيو 12, 2016

اخي ناصر

السلام عليكم

اقتباس

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

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

تسجيل الدخول

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

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

ناصر سعيد

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

ناصر سعيد

علي فاهم

جلال محمد

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

ناصر سعيد

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

جلال محمد

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

ناصر سعيد

ناصر سعيد

جلال محمد

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

جلال محمد

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

ناصر سعيد

جلال محمد

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

جلال محمد

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

ناصر سعيد

ناصر سعيد

جلال محمد

Join the conversation

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

تصفح الموقع

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

Support

Important Information