ناصر سعيد

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.officena.net/ib/applications/core/interface/file/attachment.php?id=113355

وهذا هو الكود الاخر للعلامه عبد الله باقشير 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.officena.net/ib/applications/core/interface/file/attachment.php?id=113355

كود آخر لنفس الموضوع وللعلامه عبد الله باقشير وهذا رابطه 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

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى وهما العالم العلامه والبحر الفهامه عبد الله باقشير ومعه العبقري ذو الخلق الحسن ياسر العربي - جزاهم الله كل خير - في كود لكل منهما يستطيع كود كل واحد منهم ان يستخرج الطلاب الناجحين وطلاب الدور التاني بسلاسه اولا : هذا كود العلامه عبد الله باقشير حفظه الله .. بشرح اسطر الكود Option Explicit ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير ''الهدف من الكود ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''وقد تمت اضافة جزئيه حسب المتطلبات الجديده للمدارس ''بفضل الله اولا ثم العبقري ياسر العربي ' اسماء المواد Const nTEST As String = "عربي" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "رسم" & "," & _ "العاب" & "," & _ "نشاط1" & "," & _ "نشاط 2" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء الموادوعددها Const ColmnTotal As String = "13,22,31,40,51,57,54,59,64,69,82" ' ارقام اعمدة الفصل الثاني 'ويجب ان يتساوى عددها 'مع عدد اسماء المواد 'لعليا التي كتبت ' وهنا المجموع ً Const ColmnTest2 As String = "9,18,27,36,47,54,57,62,67,72,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 6 ' اول صف للبيانات Const TopRow As Integer = 7 Sub kh_Tgrba() Dim sCont As Integer, R As Integer Dim Tst As String Dim xx As String Dim xxx As String Dim go As String Dim Arr, i, x On Error GoTo 0 '------------------ ' عدد الطلبة ' ممكن يؤخذ من خلية او يكتب كتابة sCont = Sheets("بيانات المدرسة").Range("B10").Value '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------ sCont = sCont + TopRow With ActiveSheet For R = TopRow To sCont If Not IsEmpty(.Cells(R, "C")) Then Tst = kh_Test(R) '''الاضافه هنا '--متغير اســم ورقم العمود '_ما تم التعديل عليه هذه الجزئية تم اضافة عليها بعض الاسطر Select Case .Cells(R, 112) 'لتحديد النوع للطالب Case 1: xx = "له دور ثان في": xxx = "ناجح": go = "ومنقول " & Sheets("بيانات المدرسة").Range("b16") Case 2: xx = "لها دور ثان في": xxx = "ناجحه": go = "ومنقوله " & Sheets("بيانات المدرسة").Range("b16") End Select If Len(Tst) Then .Cells(R, "CW") = xx Else .Cells(R, 101) = xxx '--متغير اسم العمود 'عمود ملاحظات المواد .Cells(R, "CX") = kh_Test(R) '--متغير رقم العمود 'عمود رقم النتيجة Select Case .Cells(R, 101) '--متغير اسم العمود 'اذا كان الطالب ناجح او ناجحةاذن يتم اعتماده منقول او منقوله للصف التالي Case xxx: .Cells(R, "CX") = go End Select x = 0 ''مصفوفة باسماء خلاياالمواد ''متغير أسماء اعمدة اختبار الترم التاني Arr = Array(.Range("i" & R), .Range("r" & R), .Range("aa" & R), .Range("aj" & R), .Range("at" & R), .Range("au" & R), .Range("bb" & R), .Range("bg" & R), .Range("bl" & R), .Range("bq" & R), .Range("bz" & R)) ' حلقة تكرارية للبحث داخل المصفوقة عن الغائب اذا وجد يتم اضافته للمتغير اكس For Each i In Arr Select Case i Case "غ": x = x + 1 End Select Next 'اذا كان المتغير اكس يساوي عدد جميع مواد الترم الثاني اذن هو غائب Select Case x Case 11: .Cells(R, "CX") = "غياب" End Select 'الشرط الثاني اذا كان المجموع يساوي صفر اذن غائب Select Case .Cells(R, 52) Case 0: .Cells(R, "CX") = "غياب" End Select 'اذا كان الطالب باق بشرط ان كون في الصف الاول او الثاني يصبح ناجح بحكم القانون If .Cells(R, 111) = "باق" And (Sheets("بيانات المدرسة").Range("b12") = 1 Or Sheets("بيانات المدرسة").Range("b12") = 2) Then: .Cells(R, "CX") = go & " بحكم القانون": .Cells(R, "Cw") = xxx '____________________________________________ End If Next End With 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم اظهار النتيجة بنجاح" End If End Sub Function kh_Test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, CC As Integer Dim ib As Boolean CC = UBound(Split(nTEST, ",")) For c = 0 To CC ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ", "غـ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ", "غـ" NN = NN & " لثلث الدرجة": ib = True Case Is < Cells(iRs, ctst) NN = NN & " لثلث الدرجة": ib = True End Select End If 1: If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN Next kh_Test = TT End Function استخراج حاله الطالب للعلامه عبد الله باقشير.rar ثانيا: هذا كود العبقري ياسر العربي حفظه الله .. بشرح اسطر الكود Sub Yasser() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''شرح الكود '' 3 متغيرات Dim LR As Integer, _ LR1 As Integer, _ T As Integer ''صف البدايه T = 7 ''متغير اسم شيت الرصد With Sheets(1) ''موقع رقم الجلوس LR1 = .Cells(7, 2) '' متغير اسم شيت الجدول ' هنا يتم جلب اول رقم الجلوس الى شيت المعادلات للعمل عليه Sheet3.Range("c6") = LR1 'متغير لمعرفة اخر صف به بيانات LR = .Cells(.Rows.Count, 1).End(xlUp).Row ''المدى المطلوب مسحه لكتابة حاله الطالب فيه Range("cw7:cx" & LR).ClearContents 'حلقة تكرارية من اول طالب الى اخر طالب For R = 7 To LR 'اذا كانت قيمة حرف التيي اكبر من او يساوي اخر طالب يذهب خارج الحلقة التكرارية الى السطر صفر If T - 1 >= LR Then GoTo 0 Else 'ايقاف تحديث الشاشة Application.ScreenUpdating = False 'هنا يتم تطبيق كود اكس اكس الخاص بوضع الفواصل بين المواد xxx ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 101) = Sheet3.Cells(2, 9) ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 102) = Sheet3.Cells(2, 10) 'هنا قيمة الخلية المذكورة الخاصة برقم جلوس ' الطالب تساوي نفسها +1 للذهاب الى الطالب التالي لتطبيق الكود مره اخرى Sheet3.Range("c6").Value = Sheet3.Range("c6").Value + 1 'وهنا بالمثل نضيف واحد الى هذا المتغير للنزول الى الصف التالي وهكذا حتى تنتهي البيانات T = T + 1 End If Next End With '' متغير اسم شيت الجدول وموقع الخليه 0 Sheet3.Range("c6") = LR1 'اعادة تحديث الشاشة Application.ScreenUpdating = True MsgBox "تم بحمد الله" End Sub ''-------------------------------------------------------- Sub xxx() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 '' هذف الكود هو وضع شرطه بين مواد الدور التاني ''شرح الكود With Sheet3 Dim Rng As Range 'حلقة تكرارية لصف المواد التى لها دور ثان For Each Rng In .Range("d10:n10") 'اذا كانت الخلية بها بيانات اذن يتم تطبيق التالي If Rng <> "" Then 'ضع المادة بالخلية الموضحه .Range("j11") = .Range("j11") & Rng 'وضع الشرطة بعد كل مادة .Range("j11") = .Range("j11") & " -" End If Next Rng 'بعد الانتهاء من وضع كل الفواصل تظل شرطة اخيرة يتم حذفها بهذه الطريقة .Range("J12").FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-1)" .Range("J12") = .Range("J12").Value .Range("j11").ClearContents End With End Sub استخراج حاله الطالب للعبقري ياسر العربي.rar حفظ الله كل من ساهم في اخراج هذا العمل المتميز

استخراج حالة الطالب ناجح ودور تان .. بطريقة اقطاب المنتدى شاء الله تعالى ان يجتمع عملان لافذاذ المنتدى وهما العالم العلامه والبحر الفهامه عبد الله باقشير ومعه العبقري ذو الخلق الحسن ياسر العربي - جزاهم الله كل خير - في كود لكل منهما يستطيع كود كل واحد منهم ان يستخرج الطلاب الناجحين وطلاب الدور التاني بسلاسه اولا : هذا كود العلامه عبد الله باقشير حفظه الله .. بشرح اسطر الكود Option Explicit ''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير ''الهدف من الكود ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''وقد تمت اضافة جزئيه حسب المتطلبات الجديده للمدارس ''بفضل الله اولا ثم العبقري ياسر العربي ' اسماء المواد Const nTEST As String = "عربي" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "رسم" & "," & _ "العاب" & "," & _ "نشاط1" & "," & _ "نشاط 2" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء الموادوعددها Const ColmnTotal As String = "13,22,31,40,51,57,54,59,64,69,82" ' ارقام اعمدة الفصل الثاني 'ويجب ان يتساوى عددها 'مع عدد اسماء المواد 'لعليا التي كتبت ' وهنا المجموع ً Const ColmnTest2 As String = "9,18,27,36,47,54,57,62,67,72,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 6 ' اول صف للبيانات Const TopRow As Integer = 7 Sub kh_Tgrba() Dim sCont As Integer, R As Integer Dim Tst As String Dim xx As String Dim xxx As String Dim go As String Dim Arr, i, x On Error GoTo 0 '------------------ ' عدد الطلبة ' ممكن يؤخذ من خلية او يكتب كتابة sCont = Sheets("بيانات المدرسة").Range("B10").Value '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------ sCont = sCont + TopRow With ActiveSheet For R = TopRow To sCont If Not IsEmpty(.Cells(R, "C")) Then Tst = kh_Test(R) '''الاضافه هنا '--متغير اســم ورقم العمود '_ما تم التعديل عليه هذه الجزئية تم اضافة عليها بعض الاسطر Select Case .Cells(R, 112) 'لتحديد النوع للطالب Case 1: xx = "له دور ثان في": xxx = "ناجح": go = "ومنقول " & Sheets("بيانات المدرسة").Range("b16") Case 2: xx = "لها دور ثان في": xxx = "ناجحه": go = "ومنقوله " & Sheets("بيانات المدرسة").Range("b16") End Select If Len(Tst) Then .Cells(R, "CW") = xx Else .Cells(R, 101) = xxx '--متغير اسم العمود 'عمود ملاحظات المواد .Cells(R, "CX") = kh_Test(R) '--متغير رقم العمود 'عمود رقم النتيجة Select Case .Cells(R, 101) '--متغير اسم العمود 'اذا كان الطالب ناجح او ناجحةاذن يتم اعتماده منقول او منقوله للصف التالي Case xxx: .Cells(R, "CX") = go End Select x = 0 ''مصفوفة باسماء خلاياالمواد ''متغير أسماء اعمدة اختبار الترم التاني Arr = Array(.Range("i" & R), .Range("r" & R), .Range("aa" & R), .Range("aj" & R), .Range("at" & R), .Range("au" & R), .Range("bb" & R), .Range("bg" & R), .Range("bl" & R), .Range("bq" & R), .Range("bz" & R)) ' حلقة تكرارية للبحث داخل المصفوقة عن الغائب اذا وجد يتم اضافته للمتغير اكس For Each i In Arr Select Case i Case "غ": x = x + 1 End Select Next 'اذا كان المتغير اكس يساوي عدد جميع مواد الترم الثاني اذن هو غائب Select Case x Case 11: .Cells(R, "CX") = "غياب" End Select 'الشرط الثاني اذا كان المجموع يساوي صفر اذن غائب Select Case .Cells(R, 52) Case 0: .Cells(R, "CX") = "غياب" End Select 'اذا كان الطالب باق بشرط ان كون في الصف الاول او الثاني يصبح ناجح بحكم القانون If .Cells(R, 111) = "باق" And (Sheets("بيانات المدرسة").Range("b12") = 1 Or Sheets("بيانات المدرسة").Range("b12") = 2) Then: .Cells(R, "CX") = go & " بحكم القانون": .Cells(R, "Cw") = xxx '____________________________________________ End If Next End With 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم اظهار النتيجة بنجاح" End If End Sub Function kh_Test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, CC As Integer Dim ib As Boolean CC = UBound(Split(nTEST, ",")) For c = 0 To CC ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ", "غـ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ", "غـ" NN = NN & " لثلث الدرجة": ib = True Case Is < Cells(iRs, ctst) NN = NN & " لثلث الدرجة": ib = True End Select End If 1: If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN Next kh_Test = TT End Function استخراج حاله الطالب للعلامه عبد الله باقشير.rar اولا : هذا كود العبقري ياسر العربي حفظه الله .. بشرح اسطر الكود Sub Yasser() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 ''استخراج حاله الطالب سواء كان ناجح او دور تان او غايب ''شرح الكود '' 3 متغيرات Dim LR As Integer, _ LR1 As Integer, _ T As Integer ''صف البدايه T = 7 ''متغير اسم شيت الرصد With Sheets(1) ''موقع رقم الجلوس LR1 = .Cells(7, 2) '' متغير اسم شيت الجدول ' هنا يتم جلب اول رقم الجلوس الى شيت المعادلات للعمل عليه Sheet3.Range("c6") = LR1 'متغير لمعرفة اخر صف به بيانات LR = .Cells(.Rows.Count, 1).End(xlUp).Row ''المدى المطلوب مسحه لكتابة حاله الطالب فيه Range("cw7:cx" & LR).ClearContents 'حلقة تكرارية من اول طالب الى اخر طالب For R = 7 To LR 'اذا كانت قيمة حرف التيي اكبر من او يساوي اخر طالب يذهب خارج الحلقة التكرارية الى السطر صفر If T - 1 >= LR Then GoTo 0 Else 'ايقاف تحديث الشاشة Application.ScreenUpdating = False 'هنا يتم تطبيق كود اكس اكس الخاص بوضع الفواصل بين المواد xxx ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 101) = Sheet3.Cells(2, 9) ''متغر اسم شيت الجدول ''وموقع الخلايا التي سيتم لصقها في عمودي الحاله 101 و 102 .Cells(T, 102) = Sheet3.Cells(2, 10) 'هنا قيمة الخلية المذكورة الخاصة برقم جلوس ' الطالب تساوي نفسها +1 للذهاب الى الطالب التالي لتطبيق الكود مره اخرى Sheet3.Range("c6").Value = Sheet3.Range("c6").Value + 1 'وهنا بالمثل نضيف واحد الى هذا المتغير للنزول الى الصف التالي وهكذا حتى تنتهي البيانات T = T + 1 End If Next End With '' متغير اسم شيت الجدول وموقع الخليه 0 Sheet3.Range("c6") = LR1 'اعادة تحديث الشاشة Application.ScreenUpdating = True MsgBox "تم بحمد الله" End Sub ''-------------------------------------------------------- Sub xxx() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 10 / 7/ 2016 '' هذف الكود هو وضع شرطه بين مواد الدور التاني ''شرح الكود With Sheet3 Dim Rng As Range 'حلقة تكرارية لصف المواد التى لها دور ثان For Each Rng In .Range("d10:n10") 'اذا كانت الخلية بها بيانات اذن يتم تطبيق التالي If Rng <> "" Then 'ضع المادة بالخلية الموضحه .Range("j11") = .Range("j11") & Rng 'وضع الشرطة بعد كل مادة .Range("j11") = .Range("j11") & " -" End If Next Rng 'بعد الانتهاء من وضع كل الفواصل تظل شرطة اخيرة يتم حذفها بهذه الطريقة .Range("J12").FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-1)" .Range("J12") = .Range("J12").Value .Range("j11").ClearContents End With End Sub حفظ الله كل من ساهم في اخراج هذا العمل المتميز استخراج حاله الطالب للعبقري ياسر العربي.rar

جزاكم الله عنا كل خير

جزاكم الله عنا كل خير

تعديل طفيف من المحترم ياسر خليل

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

جزاك الله خيراً

جزاك الله خيراً

جزاك الله خيراً

استخراج دون المستوى الطلاب الضعاف في كل المواد للمحترم ياسر العربي Sub دون_المستوى() ''''' هذا الكود للاستاذ المحترم ياسر العربي ''' جزاه الله كل خير ''' هذا الكود خاص باستخراج الطلاب دون المستوى ''' ''' Dim LR As Integer, R As Integer, T As Integer, z As Integer 'حذف النطاق الموجود لجلب بيانات جديدة Range("c6:d100").ClearContents 'يشير حرف التيي الى اول صف هنحط فيه بيانات T = 6 '''' متغير اسم شيت الهدف _دون المستوى واسم الخليه_ z = Sheet3.Range("R1").Value '''' متغير اسم شيت الهدف _دون المستوى واسم الخليه_ y = Sheet3.Range("R2").Value ''''' With Sheet1 LR = .Cells(.Rows.Count, 1).End(xlUp).Row For R = 7 To LR Application.ScreenUpdating = False If .Cells(R, z) Like "*" & "دون المستوى" & "*" Then '''' متغير اسم شيت الهدف _دون المستوى Sheet3.Cells(T, 3) = .Cells(R, 3) '''' متغير اسم شيت الهدف _دون المستوى Sheet3.Cells(T, 4) = .Cells(R, y) T = T + 1 End If Next End With Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub استخراج دون المستوى للمحترم ياسر العربي.rar

عمل ولااروع يضاف الى قائمه الاعمال المتميزه الله يبارك للنابغه ساجده العزاوي والعبقري ياسر العربي وكل من شارك في اظهار هذا العمل في المنتدى استخراج الشهادات بطريقه سهله وبمعايير مختلفه شهادات الناجحين فقط وشهادات الراسبين فقط او شهادات للاولاد فقط او شهادات للبناتفق شهادات بمعيارين يعني بالفصل والاولاد حاجه روعه وبالشرح Sub الناجحــون() ' هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في 27 يونيو 2016 'كطلب المحترم ابو أحمد محمدي ''الفكرة هنا اشرحها باختصار ''ناخذ متغير ونضيف له بعد مليء البيانات 1 '' '' فاذا المتغير زوجي نضع البيانات في الشهادة العلوية بالورقة '' واذا فردي نضع البيانات في الشهادة السفلية بالورقة '' وعند امتلاء الشهادتين نطبع الورقة '' ويتكرر اللوب.... اما اذا كانت فردية بالنهاية '' نجيك هل خلية ام 19 فارغة معناها فقط الشهادة العلوية ممتلئة '' وبهذا نعرف انها فردية فنطبعها LR = Sheet1.Range("C7").End(xlDown).Row ' ايجاد اخر صف موجود به بيانات c = 2 'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية 'واذا فردي يضع البيانات في الشهادة السفلية بالورقة For i = 7 To LR ' متغير لوب من صف 7 الي يحوي البيانات الى اخر صف به بيانات Application.ScreenUpdating = False 'لتسريع الكود وعدم رؤية مايحدث في الشيت وبذلك يتم اخفاء الرجفة If c Mod 2 = 0 Then 'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ... 'اذا كان زوجي نضع البيانات في الشهادة العلوية If Sheet1.Cells(i, 101) Like "*" & "ناج" & "*" Then 'If Sheet1.Cells(i, 101) = "ناجــــح" Or Sheet1.Cells(i, 101) = "ناجحــــة" Then 'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها ' Sheets(2).Cells(3, 13) = Sheets(1).Cells(i, 2) 'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه 'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله Sheets(2).Cells(12, 3) = Sheets(1).Cells(i, 101) Sheets(2).Cells(12, 6) = Sheets(1).Cells(i, 102) 'نضع محتوى الخلايا سواء فيها ناجح ناجحة 'او لها له دور ثاني ومنقول لصف في الخلايا اعلاه ' ' c = c + 1 'نزيد العداد حتى يصبح فردي ' وفي اللوب الثاني يذهب الى الشهادة التحت لان العليا ملأناها ' ' End If GoTo 1 'يذهب الى 1 لاخذ رقم جلوس اخر Else 'اذا كان رقم السي فردي ' If .Cells(i, 101) Like "*" & "ناجــــح" & "*" Then If Sheet1.Cells(i, 101) = "ناجــــح" Or Sheets(1).Cells(i, 101) = "ناجحــــة" Then '''رقم عمود المعيار وكلمة المعيار Sheets(2).Cells(19, 13) = Sheets(1).Cells(i, 2) Sheets(2).Cells(28, 3) = Sheets(1).Cells(i, 101) Sheets(2).Cells(28, 6) = Sheets(1).Cells(i, 102) c = c + 1 Sheets(2).Range("a1:p31").PrintOut 'وضعنا الطبع هنا في الاف الثانية وليس الاف الاولى للزوجي 'لان تأكدنا تم مليء الشهادتين بالبيانات ' ' Sheets(2).Cells(3, 13) = "" Sheets(2).Cells(19, 13) = "" 'بعد الطبع يجب تفريغ الخليتين ام3 و ام 19 ' التي تحوي ارقام الجلوس ' ' End If End If 1: Next i If Sheets(2).Cells(19, 13) = "" And Sheets(2).Cells(3, 13) <> "" Then Sheets(2).Range("a1:p15").PrintOut End If 'هذه الاف وضعناها في حالة شهادة فردية ' ففي حالة ام 19 فارغة معناها شهادة فردية فقط 'الشهادة العلوية فيها بينات ونعطيه امر بطبعها Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' شهادات محدده ''''''''''''''''''''''' ''''''''''''''''''' Sub طباعه_محدده_للأولاد() ' ' هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في 27 يونيو 2016 'كطلب المحترم ابو أحمد محمدي ''الفكرة هنا اشرحها باختصار ''ناخذ متغير ونضيف له بعد مليء البيانات 1 '' '' فاذا المتغير زوجي نضع البيانات في الشهادة العلوية بالورقة '' واذا فردي نضع البيانات في الشهادة السفلية بالورقة '' وعند امتلاء الشهادتين نطبع الورقة '' ويتكرر اللوب.... اما اذا كانت فردية بالنهاية '' نجيك هل خلية ام 19 فارغة معناها فقط الشهادة العلوية ممتلئة '' وبهذا نعرف انها فردية فنطبعها LR = Sheets(1).Range("C7").End(xlDown).Row ' ايجاد اخر صف موجود به بيانات c = 2 'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية 'واذا فردي يضع البيانات في الشهادة السفلية بالورقة For i = Sheets(2).Cells(7, 18).Value To Sheets(2).Cells(7, 19).Value 'من الخلية التي تحوي رو الطبع الى الخلية الثانية التي تحوي الى ار 7 و اس 7 Application.ScreenUpdating = False 'لتسريع الكود وعدم رؤية مايحدث في الشيت وبذلك يتم اخفاء الرجفة If c Mod 2 = 0 Then 'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ... 'اذا كان زوجي نضع البيانات في الشهادة العلوية ' If Sheets(1).Cells(i, 128) = "ذكر" Then 'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها ' Sheets(2).Cells(3, 13) = Sheets(1).Cells(i, 2) 'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه 'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله Sheets(2).Cells(12, 3) = Sheets(1).Cells(i, 101) Sheets(2).Cells(12, 6) = Sheets(1).Cells(i, 102) 'نضع محتوى الخلايا سواء فيها ناجح ناجحة 'او لها له دور ثاني ومنقول لصف في الخلايا اعلاه ' ' c = c + 1 'نزيد العداد حتى يصبح فردي ' وفي اللوب الثاني يذهب الى الشهادة التحت لان العليا ملأناها ' ' End If GoTo 1 'يذهب الى 1 لاخذ رقم جلوس اخر Else 'اذا كان رقم السي فردي If Sheets(1).Cells(i, 128) = "ذكر" Then 'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها Sheets(2).Cells(19, 13) = Sheets(1).Cells(i, 2) Sheets(2).Cells(28, 3) = Sheets(1).Cells(i, 101) Sheets(2).Cells(28, 6) = Sheets(1).Cells(i, 102) c = c + 1 Sheets(2).Range("a1:p31").PrintOut 'وضعنا الطبع هنا في الاف الثانية وليس الاف الاولى للزوجي 'لان تأكدنا تم مليء الشهادتين بالبيانات ' ' Sheets(2).Cells(3, 13) = "" Sheets(2).Cells(19, 13) = "" 'بعد الطبع يجب تفريغ الخليتين ام3 و ام 19 ' التي تحوي ارقام الجلوس ' ' End If End If 1: Next i If Sheets(2).Cells(19, 13) = "" And Sheets(2).Cells(3, 13) <> "" Then Sheets(2).Range("a1:p15").PrintOut End If 'هذه الاف وضعناها في حالة شهادة فردية ' ففي حالة ام 19 فارغة معناها شهادة فردية فقط 'الشهادة العلوية فيها بينات ونعطيه امر بطبعها Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' النابغه من اهلنا بالعراق حفظ الله العراق واذل كل من دمره شهادات من النابغه ساجده 1.rar

إظهار كل 15 شهادة التالية والسابقة abo_abary_12.rar Sub UP() If Cells(1, 13) <= Cells(1, 14) Then Cells(1, 13) = Cells(1, 13) + 14 End If End Sub Sub DOWN() If Cells(1, 13) - 14 < 0 Then GoTo 1 If Cells(1, 13) > Cells(1, 15) Then Cells(1, 13) = Cells(1, 13) - 14 End If 1 End Sub

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

شكرا للاستاذ القدير بن عليه ثم شكرا لك

وليه 3 رموز اول صف يتم الترحيل له هو الصف 7 وانت كاتب 6 ومع هذا بيرحل الى الصف 7 وحرف ال A معناه ايه

للرفع رفع الله مقداركم

M = 6: N = 6: S = 6 Range("A" & R).Range("a1:cx1").Copy With Sheets("ناجح") .Range("a" & M).PasteSpecial xlPasteValues .Range("a" & M).PasteSpecial xlPasteFormats .Range("a" & M) = M - 6 انا معجب بحلولك جزاك الله خيرا وبعد من فضلك ماذا تعني أحرف A - a - N - S --M الكابتل والاسمول

رابط كنترول الصف الرابع والخامس لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sjmj1-rar.html رابط كنترول الصف التاني والتالث لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-1642ojx1-rar.html رابط كنترول الصف الاول لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sj221-rar.html كلمه السر 1111

رابط كنترول الصف الرابع والخامس لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sjmj1-rar.html رابط كنترول الصف التاني والتالث لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-1642ojx1-rar.html رابط كنترول الصف الاول لاستاذ محترم اسمه عبد الباري البنا http://up.top4top.net/downloadf-164sj221-rar.html كلمه السر 1111

ارجوك اريد شرح لهذه الجمله

='كنترول شيت'!$C$11:INDEX('كنترول شيت'!$C$11:$C$500;COUNTA('كنترول شيت'!$C$11:$C$500)) جزاكم الله خيرا وبارك فيكم استاذ سليم =OFFSET('كنترول شيت'!$B$11;;;COUNTA('كنترول شيت'!$B$11:$B$1000)) جزاك الله خيرا استاذ ياسر

Sub KH_START() Dim b As Integer, M As Integer Sheets("كشف ناجح").Range("c7:m1000").ClearContents Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents M = 7: b = 7 Application.ScreenUpdating = False For R = 1 To 1000 If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "ناجح") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues Application.CutCopyMode = False M = M + 1 End If If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "دور ثان") Then Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues Application.CutCopyMode = False b = b + 1 End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub كود استدعاء رائع بتحسينات الاستاذ المحترم اسامه البراوي حفظه الله ترحيل مفيد باختبار اعمدة معينة 2.