كود إضافة وحذف الدوائر إعداد الحاوى

[alfa]

شكرا بارك الله فيك

Sub Frame3_Click()
'
' Frame3_Click Macro
' كود إضافة الدوائر
'================================================= ====
' أمر لعدم إهتزاز الشاشة أثناء تنفيذ الكود
Application.ScreenUpdating = False
'رسم الشكل البيضاوى - وجعله بدون تعبئة - وتغيير إسمه
' تغيير الإسم ضرورى لكى يكون جميع أسماء الدوائر التى سيتم لصقها بعد ذلك لها نفس الإسم تماما حتى يسهل حذفها جميعاً
ActiveSheet.Shapes.AddShape(msoShapeOval, -4232.25, 335.25, 54#, 54#). _
Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.Name = "Oval 1"
'================================================= ====
'تحديد الشكل البيضاوى - ثم قصه
ActiveSheet.Shapes.Range(Array("Oval 1")).Select
Selection.Cut
'================================================= ====

'تحديد أول خلية فى مادة اللغة العربية
Range("x11").Select
For I = 1 To [c1] - 1
'يمثل عدد الطلاب C1
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [x10] Then
'يمثل الخلية التى تحتوى على الحد الأدنى للنجاح X10
ActiveSheet.Paste
[a1] = [a1] + 1
'يمثل الخلية التى سيتم وضع فيها قيمة تمثل عداد ليعد عدد الدوائر التى سيتم رسمها حتى يسهل حذفها بعد ذلك A1
End If
Next I
'================================================= ====

' تحديد أول خلية فى مادة اللغة الإنجليزية
Range("AD11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [AD10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I
'================================================= ====

' تحديد أول خلية فى مادة الدراسات
Range("AJ11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [AJ10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I

'================================================= ====

' تحديد أول خلية فى مادة الرياضيات
Range("AR11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [AR10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I

'================================================= ====
' تحديد أول خلية فى مادة العلوم
Range("AX11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [AX10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I
'================================================= ====

'تحديد أول خلية فى مادة التربية الفنية
Range("BD11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [BD10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I
'================================================= ====

'تحديد أول خلية فى مادة الكمبيوتر
Range("BJ11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [BJ10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I

'================================================= ====

'تحديد أول خلية فى مادة التربية الدينية
Range("BT11").Select
'دى 5 هى الخلية الأعلى لأول خلية يراد رسم الدائرة فيها
For I = 1 To [c1] - 1
'العدد 5 يمثل عدد الطلاب
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value < [BT10] Then
ActiveSheet.Paste
[a1] = [a1] + 1
End If
Next I

'================================================= ====

Application.ScreenUpdating = True
MsgBox (" تم إضافة عدد " & [a1] & " دائرة ")
End Sub
Sub Rectangle65_Click()
'
' Rectangle65_Click Macro
'كود الحذف

'
Dim c As Integer
Dim A As String
A = "oval 1"
c = [a1]
For m = 1 To c
ActiveSheet.Shapes.Range(Array(A)).Select
Selection.Delete
Next m

MsgBox (" تم حذف عدد " & [a1] & " دائرة ")
[a1] = 0

End Sub

[hassanalhawy]

هذا تعديل ليناسب جميع أوراق العمل والشيتات
مع قيام كل صاحب شيت بتحديد عرض العمود الذى سيرسم به الدوائر واستبداله بالرقم 54
,وتحديد أرتفاع الصفوف المتقاطعة مع العمود السابق واستبداله بالرقم 50