ناصر سعيد

العملاق عمر الحسيني ربنا يحفظك

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 اعمده مثلا ماهو الحل .. اين مواقع التغيير من فضلك

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

اين الاحبه

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

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

خاصه هذا الجزء الذي اريد فهمه جزاكم الله خيرا

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

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

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 Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer '================================================ عمود_رقم_الجلوس = 2 صف_الدرجات = 12 صف_مواد_دور_ثاني = 8 عمود_حالة_الطالب = 51 عمود_المواد = 52 Set MyRng_All = Range("p13:ax1000") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ x = ActiveWindow.Zoom Application.ScreenUpdating = False Range("ay13:az1000").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 هذا هو الكود بعد تعديل للاستاذ المحترم ابو عبد الباري

الغملاق عمر الحسيني جزاك الله كل خير وبعد هل تقصد انك تعاملت مع الملف المرفق في المشاركه الاولى الموجود بها هذا الكود Sub kh_Filter() Dim LR As Long With Sheet1 LR = .Cells(.Rows.Count, "AF").End(xlUp).Row .Range("AD6:BH" & LR).AdvancedFilter xlFilterCopy, Range("aa1:aa2"), Range("c9:AF9") End With Range("a3").Select LR = Cells(Rows.Count, "AF").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address End Sub هذا هو الكود الذي اقصده وارجو بارك الله فيك شرحه

لماذ لايعمل هذا الكود الموجود بالمرفق

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 Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer '================================================ عمود_رقم_الجلوس = 2 صف_الدرجات = 12 صف_مواد_دور_ثاني = 8 عمود_حالة_الطالب = 51 عمود_المواد = 52 Set MyRng_All = Range("p13:ax65529") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ x = ActiveWindow.Zoom Application.ScreenUpdating = False Range("ay13:az65529").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 مواد بما فيهم المجموع اذن المطلوب هو كتابة ارقام الاعمدة ال6 بنقس تسلسلها ومطلوب كتابه ارقام الاعمده ال6 بنفس تسلسلها التي يوجد بها اختبار الترم التاني كده تمام .. طيب كل ماده من المواد التي كتبتها لها رقم عمود اللي فيه الدرجه النهائيه وكل ماده لها اختبار الترم التاني ماعدا المجموع ..لانه لايوجد له اختبار الترم التاني الحل تختاررقم عمود من اخر الصفحة ليكون بمثابه اختبار الترم التاني ونضع فيه نصف درجه المجموغ الكلي جزاك الله خيرا

كل عام و انتم جميعا بخير عودا حميدا استاذنا الفاضل / عادل حنفي و نتمنى وجودك دائما بيننا

حفظك الله ورعاك العملاق عمر الحسيني

اشكرك اخي الكريم ياسر .. وجزاك الله خيرا وبعد مايهمني هو الاستدعاء للدور التاني بسرعه في وجود برنامج مليء بالاكواد .. وموافق على اي فكره تؤدي للغرض

للرفع

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

حاول تشغل الكود هيشتغل امسح الناتج اللي طلع جرب استخدام الكود مرة اخرى لن يعمل وبالنسبه لتعيير التقديرات غيرتها ... ايضا لايعمل

اخي الكريم جزاك الله خيرا تعمل مره واحده وبعدها حاول تمسح بيانات الشيت التاني عشان تشغل الكود مره... لن يعمل حاول تغير في حالة الطالب تجغلها ضغيف وجيد وممتاز ونظبط الكود .. لن يعمل

جزاك الله كل خير... لاتعمل اخي الكريم