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

[hassanalhawy]

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

وهو مكتوب بطريقة مبسطة ومشروحة داخل الكود
حيث يقوم برسم شكل بيضاوى ثم يقوم بجعله بدون تعبئة ثم يقوم بتغيير إسمه إلى oval 1
ثم يقوم بقص هذا الشكل البيضاوى ثم يقوم بلصقة داخل الخلايا بشرط أن تكون قيمة هذه الخلايا أقل من الحد الأدنى لكل مادة (عمود الدرجة الفعلية لكل مادة )
ويقوم بعملية اللصق لكل مادة على حدة وذلك لعدد طلاب محدد مسبقاً من الخلية c1
وأثناء كل عملية لصق يقوم بها يتم إضافة العدد 1 إلى قيمة الخلية a1 . وهذا مفيد فى معرفة عدد الأشكال البيضاوية التى سيتم حذفها بكود الحذف

[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

[sam111egypt]

جزاك الله كل خير و زاد عملك من حسناتك

[hassanalhawy]

المشاركة الأصلية كتبت بواسطة sam111egypt

جزاك الله كل خير و زاد عملك من حسناتك

شكراً جزيلاً