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

تفصل اخي عندما تكتب احمر او اخضر او ازرق او اصفر يتم التلوين وانا شغال في تصميم كنترول شيت للمرحلة الابتدائية كلها وهرفعه دوائر.xls

Sub ترتيب_سري() Rows("7:7").Select ActiveWindow.ScrollRow = 627 ActiveWindow.SmallScroll Down:=366 Rows("7:445").Select Selection.Sort Key1:=Range("d7"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ActiveWindow.ScrollRow = 7 Range("d7").Select End Sub تحديد نطاق الترتيب ليبدأ من B7 الى K7 ترتيب.xlsb

يستحق

تمام شكرا تم التجريب بارك الله فيك

لو سمحت بعد اذنك ارفق ملف العمل مع الكود

كود نسخ البيانات من ورقة لورقة اكسل كود للنسخ.xlsb

شكرا لتعبكم جميعا ,,,,,,,,,,,,,,,,,, ممكن نصمم زر تنقل ينزل مع نزول الخلايا ويصعد مع الصعود الخلايا لاعلى بدون تجميد الصفوف

تثبيت.xlsx

خظأ

ممكن ترفق الملف التطبيق لان الازرار اللى فوق مظهرتش

ارجو التوضيح وارسال الملف مع التطبيق

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

ثبيت كل ازرار التنقل عند النزول لاسفل تثبيت.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 تم الحل شكرا خااااااااااااااااالص

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