خالد المصـــــــــــرى

ممكن توضح اكتر

ثبيت كل ازرار التنقل عند النزول لاسفل تثبيت.xlsx

ناجح(2).xlsx

تم الحل جرب يا اخي شرح كود.xlsm

مشكلة في هذا الملف عنده فتحه يتم الضغظ على الصور تلقائي مشكلة.xlsx

ايوة فى الخلايا الزرقاء لو غ او اقل من 50 له برنامج علاجي , اكبر من 50 ناجح

للاسف مش ده المطلوب , الدالة تكون في خانة نتيجة الطالب والدرجات اللى من 100 هتتغذى ارقام لو اقل من 50 او غ هنكتب في خانة نتيجة الطالب له برنامج علاجي ولو اكتر من 50 يبقى ناحج

المطلوب غير كدا

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

المطلوب عمل دالة ناجح لاكثر من 50 وله برنامج علاجي لاقل من 50 او غ ناجح.xlsx

بارك الله فيك

عمل طباعة محددة فى ورقة ارقام الجلوس وكشوف المناداة

Function circle5(dr As Range) Dim OvName As String OvName = "ty" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(0, 102, 204) .Fill.Transparency = 0 End With End Function Function circle2(dr As Range) Dim OvName As String OvName = "mh" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(255, 0, 0) .Fill.Transparency = 0 End With End Function Function circle1(dr As Range) Dim OvName As String OvName = "st" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(255, 255, 0) .Fill.Transparency = 0 End With End Function Function circle3(dr As Range) Dim OvName As String OvName = "shp" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Fill.ForeColor.RGB = RGB(0, 176, 80) .Fill.Transparency = 0 End With End Function Sub Select_Shape() Call رسم_4_الدوائر Call رسم_5_الدوائر Call رسم_6_الدوائر Call رسم_7_الدوائر End Sub Sub رسم_4_الدوائر() Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "ازرق" Then circle5 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "ازرق" Then circle5 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "ازرق" Then circle5 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "ازرق" Then circle5 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "ازرق" Then circle5 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "ازرق" Then circle5 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "ازرق" Then circle5 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "ty*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 102, 204) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_5_الدوائر() Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "اصفر" Then circle1 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "اصفر" Then circle1 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "اصفر" Then circle1 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "اصفر" Then circle1 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "اصفر" Then circle1 Cells(r, "g") End If Next r r = 0 ' عين For r = 5 To 123 If Cells(r, "h") = "اصفر" Then circle1 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "اصفر" Then circle1 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "st*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 255, 0) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_6_الدوائر() 'احمر Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "احمر" Then circle2 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "احمر" Then circle2 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "احمر" Then circle2 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "احمر" Then circle2 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "احمر" Then circle2 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "احمر" Then circle2 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "احمر" Then circle2 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "mh*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub Sub رسم_7_الدوائر() 'اخضر Dim r As Integer ' لغة عربية Application.ScreenUpdating = False For r = 5 To 123 If Cells(r, "c") = "اخضر" Then circle3 Cells(r, "c") End If Next r r = 0 ' يات For r = 5 To 123 If Cells(r, "d") = "اخضر" Then circle3 Cells(r, "d") End If Next r r = 0 ' لغة انجلة For r = 5 To 123 If Cells(r, "e") = "اخضر" Then circle3 Cells(r, "e") End If Next r r = 0 ' ن For r = 5 To 123 If Cells(r, "f") = "اخضر" Then circle3 Cells(r, "f") End If Next r r = 0 ' ين For r = 5 To 123 If Cells(r, "g") = "اخضر" Then circle3 Cells(r, "g") End If Next r r = 0 For r = 5 To 123 If Cells(r, "h") = "اخضر" Then circle3 Cells(r, "h") End If Next r r = 0 ' ديقن For r = 5 To 123 If Cells(r, "i") = "اخضر" Then circle3 Cells(r, "i") End If Next r r = 0 Dim shp As Shape For Each shp In Worksheets("رصد").Shapes If shp.Name Like "shp*" Then shp.Select With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 80) .Transparency = 0 Range("a6").Select Application.CutCopyMode = False End With End If Next shp End Sub تم الحل شكرا خااااااااااااااااالص

شكرا اخي لكن انتا نسيت اللون الازرق

شكرا اخي الكريم ربنا يزيدك

الله ينور بس انا عايز الدائرة هى اللى لونها صفراء مش الخلية

سلام عليكم الاكسل ده فيه شيت وفيه كود لعمل داوئر صفراء على اى كلمة اصفر داخل الخلايا , محتاج اخلى خلفية الدوائر اصفر بردو دوائر.xls