كيف عمل دائره حمراء على درجة الطالب

[ربيع]

كيف عمل دائرة حمراء على الدرجة التي حصل عليها الطالب اقل من 60 درجه

[السيد عبد العال]

Sub DrawOval()

Dim cCell As Range

Dim sRange As Range

Dim shShape As Shape

Dim OvName As String

On Error GoTo DR_OVAL_Err

Set sRange = Selection

For Each cCell In Selection

OvName = "oval" + cCell.AddressLocal

If IsExistShape(OvName) Then

If cCell.Value >= 60 Then

ActiveSheet.Shapes(OvName).Delete

End If

Else

If cCell.Value < 60 Then

Set shShape = ActiveSheet.Shapes.AddShape(msoShapeOval, cCell.Left, cCell.Top, cCell.Width, cCell.Height)

With shShape

.Name = OvName

.Fill.Transparency = 1#

.Line.ForeColor.SchemeColor = 10

End With

End If

End If

Next

Set cCell = Nothing

Set sRange = Nothing

Exit Sub

DR_OVAL_Err:

MsgBox Err.Error

Err.Clear

Resume Next

End Sub

Function IsExistShape(ShapeName As String) As Boolean

Dim shShape As Shape

IsExistShape = False

For Each shShape In ActiveSheet.Shapes

If shShape.Name = ShapeName Then

IsExistShape = True

Exit Function

End If

Next shShape

End Function

[adel123]

اخي السيد عبد العال

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

قمت بوضع الكود المرفق ولكن لا يعمل دوائر حمراء ارجوا من سيادتكم التوضيح اكثر

وشكرا

[السيد عبد العال]

أخى الفاضل

الكود المرفق يقوم برسم قطع ناقص (Oval) حول الخلية التى بها رقم أقل من60 حيث يتم اختيار الخلاايا المطلوبة وتشغيل الماكرو.

يقوم البرنامج بالرمور على كل خليةفى الخلاياالمختارة ومقارنة قيمتها ب الحد الأدنى

فى حالة أن القيمة أقل يقوم البرنامج بإضافة القطع بطول وعرض الخلية وتغيير لون أطاره إلى الأحمر وجعله شفاف واعطاءه اسم (عبارة عن عنوان الخلية مضاف إلى كلمة oval).

أذا كانت أكبر من الحدالأدنى يتأكد البرنامج من عدم وجود القطع وإذا كان موجودا يقوم بحذفه.

- يتجاهل البرنامج الخلايا الفارغة وكذلك التى ليس بها قيمة عددية وإذا كان بها دائرة (قطع) يقوم بمسحها.

- البرنامج زود بخاصية _ يمكن تفعيلها لجعل القطع أقل من عرض وارتفاع الخلية.

-يحتوى على function للتاكد من وجود القطع .

اتمنى ان يكون مناسبا والسلام عليكم ورحمة الله.

Sub DrawOval()
Dim fCompDegree As Single, OvMargRatio As Single
fCompDegree = 60
OvMargRatio = 0 ' Margin Ratio
Dim cCell As Range
Dim sRange As Range
Dim shShape As Shape
Dim OvName As String
On Error GoTo DR_OVAL_Err
If TypeName(Selection) <> "Range" Then
  MsgBox "SElEct Range to Ckeck"
  Exit Sub
End If
Set sRange = Selection

 For Each cCell In Selection
   OvName = "oval" + cCell.AddressLocal
   If IsExistShape(OvName) Then
        If cCell.Value >= 60 Or cCell.Formula = "" Then
          ActiveSheet.Shapes(OvName).Delete
        End If
   Else
   If cCell.Value < 60 And cCell.Formula <> "" Then
     MrH = OvMargRatio * cCell.Height / 2
     MrW = OvMargRatio * cCell.Width
     
     Set shShape = ActiveSheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, cCell.Width - MrW, cCell.Height - MrH)
      With shShape
        .Name = OvName
        .Fill.Transparency = 1#
        .Line.ForeColor.SchemeColor = 10
        End With
     End If
   End If
  Next

 Set cCell = Nothing
 Set sRange = Nothing
Exit Sub
DR_OVAL_Err:
 MsgBox Err & " : " & Error
 Err.Clear
 Resume Next
End Sub

Function IsExistShape(ShapeName As String) As Boolean
Dim shShape As Shape
IsExistShape = False
For Each shShape In ActiveSheet.Shapes
 If shShape.Name = ShapeName Then
   IsExistShape = True
 Exit Function
 End If
Next shShape
End Function

[adel123]

الاستاذ السيد عبد العال

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

شكرا جزيلا على هذا الكود الرائع قمت بتجربته ويعمل ولكن لي استفسار بسيط :

كل مره يتم تشغيل الماكرو لكي يقوم برسم الدائرة نريد الكود يعمل مباشرتا بمجرد كتابة الرقم .

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

وهناك ملاحظة ان الدائرة لا تمحى بتغير الدرجة حتى اذا تعدت الدرجة 60

وشكرا جزيلا

مع تحياتي لشخصكم الكريم

تم تعديل يونيو 10, 2004 بواسطه adel123

[السيد عبد العال]

أخى عادل حسين

حياكم الله

إليكم التعديلات المطلوبة

Sub sDrawOval()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim ssRange As Range
Set ssRange = Selection
DrawOvals ssRange, 60, 0.2
End Sub
Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String
 Application.Volatile
 DrawOvals fRange, MinDegree, MarginRatio
 fDrawOval = ""
End Function
 Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single)
 Dim cCell As Range
 Dim shShape As Shape
 Dim OvName As String, OvSheet As String
 On Error GoTo DR_OVAL_Err
 For Each cCell In sRange
 OvName = "oval" + cCell.AddressLocal
 OvSheet = cCell.Worksheet.Name
 If IsExistShape(OvName, OvSheet) Then
       If cCell.Value >= MinDegree Or cCell.Formula = "" Then
          cCell.Worksheet.Shapes(OvName).Delete
       End If
 Else
  If cCell.Value < MinDegree And cCell.Formula <> "" Then
    MrH = OvMargRatio * cCell.Height
    MrW = OvMargRatio * cCell.Width
    OvalW = cCell.Width - MrW
    OvalH = cCell.Height - MrH
    Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH)
     With shShape
       .Name = OvName
       .Fill.Transparency = 1#
       .Fill.Visible = msoFalse
       .Line.ForeColor.RGB = RGB(255, 0, 0)
       .Line.Weight = 1.25
      End With
    End If
  End If
 Next
 Set cCell = Nothing
 Exit Function
DR_OVAL_Err:
 MsgBox Err & " : " & Error
 Err.Clear
 Resume Next
End Function
Function IsExistShape(ShapeName As String, SheetName As String) As Boolean
Dim shShape As Shape
IsExistShape = False
For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes
If shShape.Name = ShapeName Then
  IsExistShape = True
Exit Function
End If
Next shShape
End Function

وهو يستخدم بإحدى طريقتين الاولى ماكرو باسم sDrawOval ييم تشغيله بعد اختيار المنطقة المرادة والثانية عبارة عن دالة -ففى أى خلية بعيدة عن المنطقة الملوب رسم الدوائر لها يتم كتابة مثل هذه المعادلة:

=fDrawOval(c3:M24;60;.2(

حيث c3:m234 هى الخلايا المطلوب رسم دائرة لها

60 الحد الأدنى

0.2 هى نسبة الهامش المتروك بين القطع وحدود الخلية

مع تحياتى

[adel123]

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

الاستاذ السيد عبد العال

شكرا جزيلا على الاهتمام وجزاك الله خيراً الكود الاول يعمل بشكل جيد واعتقد ان المعادلة الاخرى به خطأ لانها لا تعمل

اخي العزيز نحن نعمل برنامج شهادات للطلاب ولدينا شيت رئيسي به اسماء الطلاب ودرجاتهم للمواد وكما تعلم الدرجات متغيرة اي احيانا تكون فوق 60 او اقل المهم اريد ان الفت نظر سيادتكم انه اريد كود اذا اعطيته درجة اقل من60 تعمل الدائرة واذا غيرت نفس الدرجة من 60الى 40 تمحى الدائرة والعكس اي ان لا تكون الدائرة عند تفعيل الكود تبقى حتى لو تغيرت الدرجة

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

[السيد عبد العال]

السلام عليكم

المعادلة الثانية تعتمد على وجود الكود

أى بعد نسخ الكود فى module يتم كتابة المعادلة

ويتم التعامل معها مثل اى معادلة فى الأكسل ويمكن كتاباتها باحد طريقتين

يتم اختيار خانة بعيد ا عن المنطقة التى بها الدرجات و يكتب فيها معادلة شبيهة بهذه:

=fDrawOval(B2:J20;60;0.2)

مع مراعة تغيير B2:j20 ليصبح هو اسم المنطقة التى بها الدرجاتوكذللك استخدم الفاصلة بدلا من الفاصلة المنقوطة إذا كان نظامك يستلزم ذلك

الطريقة الثانية لكتابة الالة هى معالج الدوال

من القائمة:

Insert -> Function

تؤدى الى الى ظهور مربع حوارى نحتار من الصندوق بجوار cateegry

User Defined

فتظهر الدوال ومنها fDrawOval فيتم إختيارها واسكمال الصندوق الحوارى الخاص بها والذى يظهر فيه مكان لثلاث متغيرات

ٍsRange

MinDegree

OvMargRatio

[adel123]

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

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

لك من كل التحية والتقدير اخي العزيز

[adel123]

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

شكرا جزيلاً استاذي الفاضل على الشرح الجميل ,وشكرا جدا على الملف الرائع الذي ارسلته لى فهو يعمل كما اردت بالضبط فهو عمل رائع جدا .

ساعدني اخي العزيز اريد نسخة بالبرنامج لدي اولا قمت بنسخ module ووضعه بـmodule جديد في برنامجي وايضا المعادلة ولكن لا تعمل ولا اعرف السبب وعلى فكره انا استخدم اوفيس اكس بي

سأقوم بالتجربة مره اخرى الى برنامج الشهادات وسأوافيك بالرد

لك من كل التحية والتقدير اخي العزيز

تم تعديل يونيو 11, 2004 بواسطه adel123

[السيد عبد العال]

السلام عليكم

وهل تظهر الماكرو المسماة sDrawOval فى قائمة الماكرو؟

وهل تظهر الدالة fDrawOval فى معالج الدوال تحت التصنيف المسمى User Defined?

[adel123]

استاذي الفاضل

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

بالنسبة للماكرو sDrawOval فهو يظهر بقائمة الماكرو اما بالنسبة للدالة fDrawOval فهي موجوده في شريط الصيغة fx اما بالنسبة الى معالج الدوال عذراً اخي العزيز اين اجدها .

fDrawOval موجوده بوسائط الدالة هل هو معالج الدوال ام لا .

في انتظار تعليق سيادتكم ان شاء الله تحل المشكلة

ولسيادتكم جزيل الشكر على اهتمامكم جزاك الله خيرا

لك من كل التحية والتقدير

[السيد عبد العال]

السلام عليكم

إذا كان اسم الماكرو يظهر فى اسماء الماكرو هذا يعنى انك تستطيع استدعائها

فماذا يحدث عندما تختار الخلايا التى بها الدرجات ثم تشغل الماكرو؟

هل تحصل على رسالة خطأ؟

وعموما اذا نجحنا فى تشغيل الماكرو فسننج بإذن الله فى تشغيل الدالة.

اما معالج الدوال اقصد به الصندوق الحوارى الذى يظهر عند ضغط

Insert Function

ويظهر فيه تقسم الدوال إلى مجموعات

[adel123]

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

استاذي الفاضل

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

اسف سيدي على كثرة الاسئلة فيه محيرة تعمل في مكان ولا تعمل في مكان اخر اعلم ان حل المشكلة اكيد بسيطة ولكن اين هي !

تقبل سيدي من كل التحية والتقدير

[السيد عبد العال]

أخى الفاضل

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

أرجو التجربة مرة أخرى بعد هذا التعديل الطفيف ربما يحل المشكلة

مرفق ملف به تطبيق للدالة.

تم تعديل الملف فى مشاركة لاحقة

[adel123]

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

هناك خطأ بالكود عند فتح الملف يعطي رسالة compile error ارجو المعذره اخي العزيز

[السيد عبد العال]

معذرة يا أخى إليك الملف الصحيح

ovs4xp.zip

[adel123]

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

استاذي الفاضل

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

http://www.emiratesvoice.com/imagecenter/pic/adel_6.zip

[السيد عبد العال]

أخى الفضل قبل كل شئ أحب أن أحيك على مستوى العمل الذى قمتم به فإخراجه جميل

ثانيا: إليكم ماكرو أخرى أضافة إلى الماكروهات السابقة

وهى تقوم بمسح جميع الدوائر فى الشيت النشطة عند استدعائها

Sub sClearAllOvals()
Dim shShape As Shape
For Each shShape In ActiveSheet.Shapes
        If Mid(shShape.Name, 1, 4) = "oval" Then shShape.Delete
Next
End Sub

أما المشكلة فى الكود السابق هى ان الأكسل يحدث منه خطأ فى حساب الإحداثيات الخاصة بالدوائر والخلايا عندما تكون نسبة ال

Zoom

مختلفة عن 100%

لهذا السبب كانت الدوائر ترسم فى أماكن مختلفة عنالماكن المتوقع لها كأن ترسم فى أقصى يسار الشييت

وعموما سأحاول معرفة كيفية تأثير هذه العلاقات

وكحل مبدئى يمكن لسيادتكم ضبط نسبة View -> Zoom إلى 100% عند العمل

وتصورى للخطوات هو كالتالى:

- يتم نقل الماكرو السلبق إلى الModule

- يتم ضبط Zoom 100%

يتم استدعاء الماكرو sClearAllOvals

يتم عمل Copy ثم Paste فى نفس مكانه من الصف ذو الخلايا الصفراء

وبالتالى تقوم الدوال بالرسم مرة أخرى

يكرر العمل السابق لكل الشيتات

ولكم تحياتى

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

[حسام نور]

تحيه على هذا العمل الرائع

[adel123]

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

استاذي الفاضل

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

استاذي الفاضل لك مني تحية طيبة وكل الاحترام وشكراً

تم تعديل يونيو 15, 2004 بواسطه adel123

[محمد طاهر عرفه]

عمل ممتاز ، و مثال مميز جدا

جزاك الله خيرا

[السيد عبد العال]

الأخ الاستاذ حسام نور

الأخ الاستاذ عادل حسين

الأخ المهندس / محمد طاهر

جزاكم الله خيرا على هذا التشجيع

لازلت هناك مشكلة لم أطرحها بعد لانشغالنا بالمشكلة السابقة:

Bug: ماذا يحدث للدالة fDrawOval() عند حذف أوإضافة خلايا اوصفوف أو أعمدة من ال Range المحدد فى متغيراتها؟

[adel123]

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

الاستاذ الفاضل / السيد عبد العال

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

تحية طيبة استاذي العزيز ونأسف عن الازعاج

[ابومؤنس]

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

بعد اذن الاخ سيد عبد العال

اذا كان وجود الماكرو الاخير هو سبب المشكلة يمكنك الاستفادة من خاصية عمل الماكرو علي كل المصنفات المفتوحة ,

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

اتمني لك كل التوفيق ,,,,