ابو عبدالبارى قام بنشر يونيو 5, 2016 قام بنشر يونيو 5, 2016 في ٤/٦/٢٠١٦ at 11:02, ناصر سعيد said: جزاك الله كل خير وبارك لك استاذ ابو عبد الباري لو تكرمت شرحك مفهوم .. ولكن نقطه المجموع كيف تم حلها ؟ ممكن بفكرتك المفيده والرائعه في نقليل عدد الطلاب فزادت سرعه الكود .. هل يمكن اضافه ان هذا العدد يساوي عدد طلاب الصف الموجود بالصفحه الرئيسيه ... يدل ال 1000 اخى العزيز/ ناصر سعيد شكرا لكلماتك الرقيقة اما بالنسبة للمطلوب غى المرفق التالى تعديل مواد الصف الثاني.rar
ناصر سعيد قام بنشر يونيو 5, 2016 قام بنشر يونيو 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 قام بنشر يونيو 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 الكاتب قام بنشر يونيو 6, 2016 اخي ابو عبد الباري رمضان كريم اقتباس المواد ما بعد المجموع الكلى ماذا لو رسب اى طالب بها لن تظهر فى مواد الرسوب لأنى لاحظت (انة لا يوجد طالب راسب فى هذه المواد ) المواد بعد المجموع الكلي مثلها مثل باقي المواد قبل المجموع الكلي جرب ان تجعل طالب راسب في احداها وشاهد .... جرب في الملف المرفق في الرابط اقتباس اما بالنسبة لملفى انا قمت برفعه لأبداء الملاحظات علية ملفك جميل .... وانشاء الله سأحاول استفيد منه وخصوصا في حالة الطالب المعفي لأني تعرضت لها هذا العام ورمضان كريم .... وكل عام وانت وجميع المسلمين بخير اسف رابط الملف http://www.kuwaiti.co/l6ix9221b464
ابو عبدالبارى قام بنشر يونيو 6, 2016 قام بنشر يونيو 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 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: الاستاذ المحترم ابو عبد الباري ربنا يبارك لك وبارك لنا فيك وفى كل الأخوة بالمنتدى ورمضان كريم 1
جلال محمد قام بنشر يونيو 7, 2016 الكاتب قام بنشر يونيو 7, 2016 اقتباس بارفاقك الملف الأصلى فى آخر مشاركة فانه يظهر مابعد المجموع الكلى لتغيير النطاق به فعلا استاذ ابو عبد الباري 1
ابو عبدالبارى قام بنشر يونيو 7, 2016 قام بنشر يونيو 7, 2016 اخى الكريم جلال محمد تم الوصول لحل لمشكلتك فى الملف المرفق اذا اعجبك الحل فضلا منك شارك به فى موضوع جديد ليستفيد منه اعضاء المنتدى الكريم وكل عام وانتم بخير ......... http://www.mediafire.com/download/lk5h2r5v81430nz/العلمي_جديد.rar
ناصر سعيد قام بنشر يونيو 8, 2016 قام بنشر يونيو 8, 2016 ارجو بعد اذن حضراتكم تضبيط هذا الكود ليعمل تجربه1.rar
جلال محمد قام بنشر يونيو 9, 2016 الكاتب قام بنشر يونيو 9, 2016 اخي ابو عبد الباري السلام عليكم جزاك الله خيرا علي مجهودك العظيم ولكن اريد منك شرح الأجزاء التي بها تعديل .... كما في الصورة المرفقة
ابو عبدالبارى قام بنشر يونيو 9, 2016 قام بنشر يونيو 9, 2016 6 ساعات مضت, جلال محمد said: اخي ابو عبد الباري السلام عليكم جزاك الله خيرا علي مجهودك العظيم ولكن اريد منك شرح الأجزاء التي بها تعديل .... كما في الصورة المرفقة اخى الكريم جلال محمد تم استخدام المتغير y لحساب عدد الصفوف االموجود بها الطلبة حتى لا يتأخر تنفيذ الماكرو كما طلب الأستاذ / ناصر سعيد
جلال محمد قام بنشر يونيو 10, 2016 الكاتب قام بنشر يونيو 10, 2016 اخي ابو عبد الباري السلام عليكم اقتباس تم استخدام المتغير y لحساب عدد الصفوف االموجود بها الطلبة حتى لا يتأخر تنفيذ الماكرو كما طلب الأستاذ / ناصر سعيد هذا الحل فعلا قام بتسريع الكود .... ولكن انا لاحظت ان هذا الحل قضي علي مشكلة عمود المجموع ايضا ولي سؤال عن الرقم المشار الية في الصورة المرفقة ..... علام يدل الرقم +12
ابو عبدالبارى قام بنشر يونيو 11, 2016 قام بنشر يونيو 11, 2016 اخى الكريم جلال محمد بالنسبة الى +12 اى يبدأ عد الصفوف التى بها طلبة من الصف 12 وذلك كما ذكرت لتسريع الكود أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر
ناصر سعيد قام بنشر يونيو 11, 2016 قام بنشر يونيو 11, 2016 24 دقائق مضت, ابو عبدالبارى said: اخى الكريم جلال محمد أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر الاستاذ ابو عبد الباري جزاك الله خيرا .. زدني فهما لهذه الجزئيه كرما منك
جلال محمد قام بنشر يونيو 11, 2016 الكاتب قام بنشر يونيو 11, 2016 (معدل) اخي ابو عبد الباري اقتباس أما لحل مشكلة المجموع فهى كما مشار اليها باللون الأحمر اي جزء احمر هل تقصد هذا ام تقصد هذا فانا اعلم ان الجزء الأول خاص بتحديد مجال التحديث والجزء الثاني لتحديد عمود حالة الطالب ومواد الدور الثاني تم تعديل يونيو 11, 2016 بواسطه جلال محمد
ابو عبدالبارى قام بنشر يونيو 11, 2016 قام بنشر يونيو 11, 2016 Set MyRng_All = Range("p13", Cells(Y, 95)) حل المشكلة فى هذه الجزئية
جلال محمد قام بنشر يونيو 11, 2016 الكاتب قام بنشر يونيو 11, 2016 اخي ابو عبد الباري كدة وضحت الفكرة ...... الحل رائع ... وعبقري جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك شكرا لك .
ابو عبدالبارى قام بنشر يونيو 11, 2016 قام بنشر يونيو 11, 2016 منذ ساعه, جلال محمد said: اخي ابو عبد الباري كدة وضحت الفكرة ...... الحل رائع ... وعبقري جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك شكرا لك . اخى الكريم جلال محمد انا فى المشاركات السابقة حددت المشكلة وهذا جزء كبير من الحل وتركت الباب مفتوح للأخوة الزملاء لتقديم حلول وقدمت انا احد هذه الحلول عل وعسى ان يقدم احد الأخوة حلولا اخرى بارك الله فيك وشكرا لكلماتك الجميلة و رمضان كريم
ناصر سعيد قام بنشر يونيو 11, 2016 قام بنشر يونيو 11, 2016 1 ساعه مضت, جلال محمد said: اخي ابو عبد الباري كدة وضحت الفكرة ...... الحل رائع ... وعبقري جزاك الله خيرا .... مجهود رائع .... تشكر علية .... اللهم اجعلة في ميزان حسناتك شكرا لك . ارجو كما وضحت الفكره لك وضحها اكثر لنا جزاك الله خيرا
ناصر سعيد قام بنشر يونيو 12, 2016 قام بنشر يونيو 12, 2016 23 ساعات مضت, ابو عبدالبارى said: Set MyRng_All = Range("p13", Cells(Y, 95)) احبابي في الله .. هل معنى هذا ان الرقم 95 الموجود هو رقم عمود المجموع وبكده تتحل مشكله عمود ربع الدرجه
جلال محمد قام بنشر يونيو 12, 2016 الكاتب قام بنشر يونيو 12, 2016 اخي ناصر السلام عليكم اقتباس احبابي في الله .. هل معنى هذا ان الرقم 95 الموجود هو رقم عمود المجموع وبكده تتحل مشكله عمود ربع الدرجه فعلا اخي ناصر تم نقل او تكرار عمود المجموع الكلي الي العمود 95 .... وبهذا تم حل مشكلة ربع الدرجة بالنسبة لعمود المجموع .... لأن الكود عندما يقوم بمقارنة عمود المجموع بعمود ربع الدرجة يجدة فارغ .... بشرط حزف حرف ( م ) من عمود المجموع الأصلي ...... الحل رائع وبسيط ..... جزي الله الأستاذ ابو عبد الباري خيرا ..... وشكرا للجميع ..... ورمضان كريم 2
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.