كود رسم دوائر حول الحصص

[عطية23]

الملف المرفق به حصص والمطلوب اذا تكرمتم وضع دوائر حول الحصص الزائدة والملف به شرح المطلوب ولك الشكر 

وضع دوائر حمراء على الحصص.xls

[ابراهيم الحداد]

السلام عليكم ورحمة الله

الكود الاول لمسح الدوائر

Sub DelShap()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.AutoShapeType = msoShapeOval Then
sh.Delete
End If
Next
End Sub

الكود الثانى لرسم الدوائر للحصص الزائدة

Sub AddCircles1()
Dim Shp As Shape
Dim i As Long, j As Long, p As Long
Dim C As Range, x As Integer
x = Range("V1").Value
i = 10
Do While i >= 7
j = 4
For Each C In Range(Cells(j, i), Cells(12, i))
If C.Value <> "" Then
Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _
C.Left, C.Top, C.Width, C.Height)
p = p + 1
Shp.Fill.Visible = msoFalse
Shp.Line.Weight = 1.5
Shp.Line.ForeColor.SchemeColor = 10
If p >= x Then Exit Sub
End If
Next
j = j + 2
i = i - 1
Loop

End Sub

الكود الاخير لرسم الدوائر فى الجدول الثانى

Sub AddCircles2()
Dim Shp As Shape
Dim i As Long, j As Long, p As Long
Dim C As Range, x As Integer
DelShap
x = Range("W1").Value
i = 13
Do While i <= 19
j = 4
For Each C In Range(Cells(j, i), Cells(12, i))
If C.Value <> "" Then
Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _
C.Left, C.Top, C.Width, C.Height)
p = p + 1
Shp.Fill.Visible = msoFalse
Shp.Line.Weight = 1.5
Shp.Line.ForeColor.SchemeColor = 10
If p >= x Then Exit Sub
End If
Next
j = j + 2
i = i + 1
Loop

End Sub

 

[عطية23]

استاذنا العزيز ابراهيم تحية طيبة 

كود رائع ونفذ المطلوب وهذا يجعلنى اطمع في كرمك ماذا لوكان عدد الجداول 6 كما في المرفق وكل جدول منهم له عدد حصص مطلوب وضع دوائر عليها بعدد  مختلف اى ان انفذ الكود على الـ 6 جدول ليس جدولين فقط واخيراً جزيل الشكر مقدماً

وضع دوائر حمراء على الحصص.xls

[عطية23]

فضلا الخلايا الفارغة تحت اسم المدرس بالجدول ارجو الا يحتسبها الكود لانى عنداضع الفصل تحت اسم المدرس يضع عليه دائرة

[عطية23]

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

وضع دوائر حمراء على الحصص.xls

[ابراهيم الحداد]

السلام عليكم ورحمة الله

تم التعديل ليعمل على خلايا الفصول فقط

Sub AddCircles1()
Dim Shp As Shape
Dim i As Long, j As Long, p As Long
Dim C As Range, x As Integer, y As Integer
DelShap
x = Range("V1").Value
i = 10
Do While i >= 6
j = 5
Do While j <= 13
For Each C In Range(Cells(j, i), Cells(13, i))
On Error Resume Next
y = InStr(C.Value, "/")
If C.Value <> "" And y > 0 Then
p = p + 1
Set Shp = ورقة1.Shapes.AddShape(msoShapeOval, _
C.Left, C.Top, C.Width, C.Height)
Shp.Fill.Visible = msoFalse
Shp.Line.Weight = 1.5
Shp.Line.ForeColor.SchemeColor = 10
If p >= x Then Exit Sub
End If
Next
i = i - 1
Loop
j = j + 2
Loop

End Sub

 

[عطية23]

السلام عليكم

الكود ممتاز ويفى بالمطلوب بارك الله فيكم وزادكم بسطة في العلم وفي الحلم وجزاكم خيراً بما عملتم ولكن لى طلب بسيط وهو تعديل الكود ليبدأ وضع الدوائر من الحصص الاولى وذلك كي اطبقه على الجدول الثانى لان المطلوب في الجدول الثانى ان يتم وضع 30 دائرة على الحصص الاولى وليست الاخيرة اسف على ازعاجكم وارهاقكم 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

اليك الكود الثانى

Sub AddCircles2()
Dim Shp As Shape, ws As Worksheet
Dim i As Long, j As Long, p As Long
Dim C As Range, x As Integer, y As Integer
'DelShap
Set ws = Sheets("ورقة1")
x = ws.Range("W1").Value
i = 13
Do While i <= 20
j = 5
For Each C In ws.Range(Cells(j, i), Cells(13, i))
On Error Resume Next
y = InStr(C.Value, "/")
If C.Value <> "" And y > 0 Then

Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, _
C.Left, C.Top, C.Width, C.Height)
p = p + 1
Shp.Fill.Visible = msoFalse
Shp.Line.Weight = 1.5
Shp.Line.ForeColor.SchemeColor = 10
If p >= x Then Exit Sub
End If
Next
j = j + 2
i = i + 1
Loop

End Sub

 

[عطية23]

السلام عليكم استاذنا الغالى

شكر الله لك وجزاك واعطاك وبارك في ذريتك 

وفيت وكفيت جعله الله في ميزان حسناتك وجعله علم ينتفع به 

شكراً