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

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

جلال محمد

بواسطه جلال محمد
في منتدى الاكسيل Excel

 مشاركة

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

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

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

قام بنشر
قام بنشر
في ٤‏/٦‏/٢٠١٦ 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   اعمده مثلا

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

 

تم تعديل بواسطه ناصر سعيد
تكبير الخط
رابط هذا التعليق
شارك
علي فاهم

علي فاهم

قام بنشر
قام بنشر 
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
  • Like 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:

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

ربنا يبارك لك
 

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

  • Like 1
رابط هذا التعليق
شارك
ابو عبدالبارى

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

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

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

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

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

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

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

قام بنشر
قام بنشر
6 ساعات مضت, جلال محمد said:

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

السلام عليكم 

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

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

 

Untitled.jpg

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

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

رابط هذا التعليق
شارك
جلال محمد

جلال محمد

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

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

السلام عليكم 

اقتباس

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

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

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

Untitled1.jpg

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

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

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

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

 

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

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

ناصر سعيد

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

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

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

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

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

رابط هذا التعليق
شارك
جلال محمد

جلال محمد

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

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

اقتباس

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

اي جزء احمر 

هل تقصد هذا 

22222.jpg

ام تقصد هذا 

11111.jpg

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

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

تم تعديل بواسطه جلال محمد
رابط هذا التعليق
شارك
ابو عبدالبارى

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

قام بنشر
قام بنشر
منذ ساعه, جلال محمد said:

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

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

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

شكرا لك .

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

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

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

 

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

ناصر سعيد

قام بنشر
قام بنشر
1 ساعه مضت, جلال محمد said:

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

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

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

شكرا لك .

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

رابط هذا التعليق
شارك
جلال محمد

جلال محمد

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

اخي ناصر 

السلام عليكم 

اقتباس

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

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

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept