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

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

شكرا أخى أبو مؤنس على المعلومة وإن كنت أظن أن أن العمل فى ملف واحد .

وعموما أرجو ان لا يسبب الكود الآتى مشاكل:

Sub sDrawOval()
 If TypeName(Selection) <> "Range" Then Exit Sub
 Dim ssRange As Range
 Set ssRange = Selection
 DrawOvals ssRange, 48, 0.2
End Sub

Function fDrawOval(ByVal fRange As Range, Optional ByVal MinDegree As Single = 0, Optional ByVal MarginRatio As Single = 0) As String
 If IsEmpty(fRange) Then Exit Function
 DrawOvals fRange, MinDegree, MarginRatio
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
 Dim MrH As Single, MrW As Single, OvalW As Single, OvalH As Single
 On Error GoTo DR_OVAL_Err
 For Each cCell In sRange
   OvName = "oval" + cCell.AddressLocal
   If IsExistShape(OvName, cCell) 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, cCell As Range) As Boolean
 Dim shShape As Shape
 IsExistShape = False
 For Each shShape In cCell.Worksheet.Shapes
   If shShape.Name = ShapeName Then
     IsExistShape = True
     Exit Function
   End If
 Next shShape
End Function

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

ومعلوم ان بهذا الكود مشكلتان:

1- خطأ فى حساب الإحداثى السينى للأشكال (الدوائر ) عندما يتم توليدها فى شيت ذات اتجاه من اليمين إلى اليسار عندما تكون نسبة zoom مختلفة عن 100% - لا تحدث هذه المشكلة عندما يكون اتجاه الشيت من اليسار لليمين.

2- لا يعمل بصورة جيدة فى حالة حذف أو إدراج صف أو عمود - برجاء تجربة الحالات المختلفة .

[برد الصباح]

بارك الله لك في علمك يا أخي زاد منه الكثير....

[صقر فلسطين]

اخواني الكرام جزاكم الله خيرا جميعا على هذا المجهود الرائع

لي طلب بسيط اخوكم عضو جديد

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

مثلا على عمود العربي و الانجليزي و الدراسات و هكذا الى نهاية المواد

فكيف يتم ذلك

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

ارجوا الا اكون قد اثقلت على حضراتكم و جزاكم الله خيرا

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

أخى الفاضل

بعد نقل الأكواد السابقة إلى Module

نفترض أن درجات مادة التاريخ موجودة فى الخلايا P16:P45 وأن الحد الأدنى لمادة العلوم هو 48 فنذهب لخلية بعيدا عنهم ولتكن أسفل مثل الخلية P56 مثلا ونكتب هذه المعادلة

=fDrawOval(P16:P45,48,0.2)

نفترض أن درجات مادة الرياضيات موجودة فى الخلايا V16:V45وأن الحد الأدنى لمادة الياضيان هو 98 فنذهب لخلية بعيدا عنهم ولتكن أسفل مثل الخلية V56 مثلا ونكتب هذه المعادلة

=fDrawOval(V16:V45,98,0.2)

مع مراعاة المشكلتين المذكورتين

ولك تحياتى

[صقر فلسطين]

اولا جزاكم الله خيرا اخي الكريم و ادعوا الله الا اكون قد اثقلت عليكم

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

انا نسخت هذا الكود فقط

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

و يعتبر اخر كود تم تعديله من قبل حضراتكم

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

ثالثا

لقد حاولت عدة مرات و لا ادري ما سبب عدم تفعيل المعادلة

ثالثا قمت بمحاولة التغير في الكود نفسه بعد تحديد العمود و الدرجات المرادة اكتب في الكود بدلا من 60 الكتب الدرجة المرادة

ثم اختار run فيتم عمل الدوائر الحمراء و هكذا تم على كل الاعمدة و الدرجات فهل هذة الخطوات سليمة

لانني في كل مرة افتح الكود نفسه و اضع الدرجة المطلوبة لكل مادة و اختار run فيقوم بعمل الدوائر

رابعا و اخيرا

عند تغير الدرجة المعمول حولها الدائرة لا يتم مسح الدائرة و لا اعرف لماذا ؟

يعني الطالب اللي اقل من 60 يأخذ دائر حمراء و اذا تحولت الى 70 مثلا تظل الدائرة الحمراء كما هي فما الحل ؟

ارجوا الا اكون قد اثقلت على حضراتكم

فانت نعم الاخ باذن الله

اخوك محمد البدري

[صقر فلسطين]

يبدوا اخي الحبيب

ايضا ان ملف الكود الذي قمت بنسخه لم انسخه بطريقة سليمة

لانني قمت بتحميل الملف الذي وضعه احد الاخوة الافاضل و قمت حضراتكم بالرد عليه

عند فتح المف اخبرني بتشغيل الماكرو ام لا فقمت بتشغيله

فوجدت ان الدوائر الحمراء الموجودة اذا تغيرت الدرجات اختفت الدائرة

و لما اردت الذهاب الى الكود المكتوب لاعرف ماذا فعل فشلت حقيقة

alt f11 لم تنفع

ارجوا الرد علي اخي الكريم

هل الطريقة التي ذكرتها تنفع

و كيف استطيع الغاء الدائرة الحمراء اذا كانت الدرجة تعدت المسموح

و كيف اتأكد ان الكود او الماكرو يعمل بشكل جيد

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

شكرا أخى أبو مؤنس  على المعلومة وإن كنت أظن أن أن العمل فى ملف واحد .

وعموما أرجو ان  لا يسبب الكود الآتى مشاكل:

Sub sDrawOval()<!--QuoteEBegin--> If TypeName(Selection) <> "Range" Then Exit Sub<!--QuoteEBegin--> Dim ssRange As Range<!--QuoteEBegin--> Set ssRange = Selection<!--QuoteEBegin--> DrawOvals ssRange, 48, 0.2<!--QuoteEBegin-->End Sub

<!--QuoteEBegin-->Function fDrawOval(ByVal fRange As Range, Optional ByVal MinDegree As Single = 0, Optional ByVal MarginRatio As Single = 0) As String<!--QuoteEBegin--> If IsEmpty(fRange) Then Exit Function<!--QuoteEBegin--> DrawOvals fRange, MinDegree, MarginRatio<!--QuoteEBegin-->End Function

<!--QuoteEBegin-->Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single)<!--QuoteEBegin--> Dim cCell As Range<!--QuoteEBegin--> Dim shShape As Shape<!--QuoteEBegin--> Dim OvName As String<!--QuoteEBegin--> Dim MrH As Single, MrW As Single, OvalW As Single, OvalH As Single<!--QuoteEBegin--> On Error GoTo DR_OVAL_Err<!--QuoteEBegin--> For Each cCell In sRange<!--QuoteEBegin-->   OvName = "oval" + cCell.AddressLocal<!--QuoteEBegin-->   If IsExistShape(OvName, cCell) Then<!--QuoteEBegin-->    If cCell.Value >= MinDegree Or cCell.Formula = "" Then<!--QuoteEBegin-->       cCell.Worksheet.Shapes(OvName).Delete<!--QuoteEBegin-->     End If<!--QuoteEBegin-->   Else<!--QuoteEBegin-->    If cCell.Value < MinDegree And cCell.Formula <> "" Then<!--QuoteEBegin-->     MrH = OvMargRatio * cCell.Height<!--QuoteEBegin-->     MrW = OvMargRatio * cCell.Width<!--QuoteEBegin-->     OvalW = cCell.Width - MrW<!--QuoteEBegin-->     OvalH = cCell.Height - MrH<!--QuoteEBegin-->     Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH)<!--QuoteEBegin-->     With shShape<!--QuoteEBegin-->       .Name = OvName<!--QuoteEBegin-->       .Fill.Transparency = 1#<!--QuoteEBegin-->       .Fill.Visible = msoFalse<!--QuoteEBegin-->       .Line.ForeColor.RGB = RGB(255, 0, 0)<!--QuoteEBegin-->       .Line.Weight = 1.25<!--QuoteEBegin-->      End With<!--QuoteEBegin-->    End If<!--QuoteEBegin-->  End If<!--QuoteEBegin--> Next<!--QuoteEBegin--> Set cCell = Nothing<!--QuoteEBegin--> Exit Function<!--QuoteEBegin-->DR_OVAL_Err:<!--QuoteEBegin--> MsgBox Err & " : " & Error<!--QuoteEBegin--> Err.Clear<!--QuoteEBegin--> Resume Next<!--QuoteEBegin-->End Function<!--QuoteEBegin-->

<!--QuoteEBegin-->Function IsExistShape(ShapeName As String, cCell As Range) As Boolean<!--QuoteEBegin--> Dim shShape As Shape<!--QuoteEBegin--> IsExistShape = False<!--QuoteEBegin--> For Each shShape In cCell.Worksheet.Shapes<!--QuoteEBegin-->   If shShape.Name = ShapeName Then<!--QuoteEBegin-->     IsExistShape = True<!--QuoteEBegin-->     Exit Function<!--QuoteEBegin-->   End If<!--QuoteEBegin--> Next shShape<!--QuoteEBegin-->End Function<!--QuoteEBegin-->

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

ومعلوم ان بهذا الكود مشكلتان:

1- خطأ فى حساب الإحداثى السينى للأشكال (الدوائر ) عندما يتم توليدها فى شيت ذات اتجاه من اليمين إلى اليسار عندما تكون نسبة zoom مختلفة عن 100% - لا تحدث هذه المشكلة عندما يكون اتجاه الشيت من اليسار لليمين.

2- لا يعمل بصورة جيدة فى حالة حذف أو إدراج صف أو عمود - برجاء تجربة الحالات المختلفة .

هذا هو أخر تعديل

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

Adel_8.zip

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

[صقر فلسطين]

الحمد لله حمد كثير طيبا مباركا فيه ملىء السموات و الارض

اخي الحبيب

جزاكم الله خير الجزاء على ما قدمتموه لنا و لغيرنا من الاخوة الافاضل

بارك الله لنا فيكم و جعل الجنة مثواكم انشاء الله تعالى

و تحية تقدير و اجلال خاصة اليك استاذنا الفاضل الاستاذ السيد عبد العال

جعلك الله عونا لجميع الاخوة

و تقبلوا مع فائق الاحترام

اخوك محمد البدري

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

جزاكم الله خيرا ونفعكم الله به

[baran]

baran

هل استطيع الحصول منكم على مثال جاهز

مع الشكر

[فرقدي]

السلام عليكم

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

بارك الله فيك مجهودك الطيب

لقت دهشت حقا بالمثال الذي اوردتموه في الملف المرفق

وارجو ان تتقبلوا استفساري

عندما حاولت تكبير حجم الأعمدة تغير حجم الدائرة الحمراء بحيث اصبحت اضيق من الدرجة

كيف استطيع ضبط حجم الدائرة بعد تغيير حجم الخلايا ؟!

مع الشكر سلفا .

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

الأخ baran المثال فى المشاركة بتاريخ 30/6/2004 Adel_8.zip

الأخ فرقدى :

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

وهناك طريقة للتحديث :

1- يتم حذف جميع الدوائر عن طريق الماكرو sClearAllOval()

2- يتم عمل نسخ ولصق فى نفس المكان لأاى صف من صفوف الدرجات التى فى نطاق الدالة fDraowOval()

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

وزاقبلوا تحياتى

[صقر فلسطين]

اخواني الكرام

تحية طيبة و بعد

كيف استطيع مسح الدوائر الحمراء من عمود ما ؟

ما هي المعادلة التي اكتبها فيقوم بمسح الدوائر الحمراء

و لكم جزيل الشكر

[adel123]

الأخ baran المثال فى المشاركة بتاريخ 30/6/2004  Adel_8.zip

الأخ فرقدى :

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

وهناك طريقة للتحديث :

1- يتم حذف جميع الدوائر عن طريق الماكرو sClearAllOval()

2- يتم عمل نسخ ولصق فى نفس المكان لأاى صف من صفوف الدرجات التى فى  نطاق الدالة fDraowOval()

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

وزاقبلوا تحياتى

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

اخي العزيز لمسح الدوائر يجب تشغيل الماكرو للمسح

1- يتم حذف جميع الدوائر عن طريق الماكرو sClearAllOval()

كما وضحها استاذنا الفاضل السيد عبد العال

[صقر فلسطين]

جزاكم الله خيرا اخي الحبيب الاستاذ عادل

تم المسح بنجاح

بارك الله فيك و في الاستاذ السيد عبد العال

و لكن لي استفسار بسيط

لقد قام بمسح كل الدوائر لكل المواد الموجودة داخل الشيت و هذا مطلوب

و لكن اذا اردت ان امسح دوائر مادة واحدة فقط اي عمود واحد فقط و ليس كل الشيت

ماذا افعل ؟

و تقبلوا مع فائق احترامي و تقديري

اخوك محمد

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

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

يتم العمل على خطوتين

1- أدخال الحد الادنى

وفيها نختار مجموعة معينة من الخلايا وننفذ ماكرو SetMinDegree

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

2- بعد ادخال الدرجات يتم استدعاء ماكرو أخرى لرسم الدوائر

وعيب هذه الطريقة انه يجب استدعاءها بعد التعديلات

وميزتها انه يمكن تلافى جميع المشاكل السابقة

إذا شاء ربنا وقدر اكتبها وأعرضها عليكم - كحل أضافى

وتقبلوا تحياتى

[صقر فلسطين]

بارك الله فيك استاذ السيد عبد العال

و نحن في انتظار هذه المعلومات القيمة

و اشكر لك

انك مازلت تذكر طلبي هذا ؟

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

و نحن في الانتظار

تم تعديل يوليو 15, 2004 بواسطه محمد البدري

[smart]

السلام عليكم

ممكن اذا تقوموا بتعديل الكود لوضع دائرة حول كلمة :

ناجح أو راسب او مكمل

اذا حصل الطالب على أكثر من نصف المجموع ولنفترض انه 900 يضع دائرة حول ناجح أو إذا كان ناجحا في جميع المواد

واذا كان راسبا في أربعة مواد أو أكثر يضع الدائرة حول كلمة راسب

واذا كان راسبا في ثلاث مواد يضع الدائرة حول مكمل

ارجو ان اكون موفقا في عرض سؤالي وأتمنى عليكم الاجابة

[smart]

السلام عليكم

لا أدري وضعت مشاركة في نفس الموضوع أمس ولكن هل حذفها المشرف أم اننني لما ارفعها لا أدري ؟؟

على العموم سؤاي كالتالي اخواني .

كيف ممكن رسم دائرة في الشهادة حول كلمة ناجح أو راسب او مكمل مع العلم ان الكلات الثلاثة مكتوبة بالشهادة

ناجح اي في جميع المواد

راسب اكثر من ثلاث مواد يكون راسب فيها

مكمل راسب في ثلاث مواد

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

ولكم الشكر

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

طبعا أذا كان الموضوع ضرورى ممكن تعديل الكود او حتى كتابة كود جديد وعموما هذه بعض المقترحات :

1- يمكن الستعاضة عن الدائرة الحمراء بمستطيل عن طريق التنسيق الشرطى

2-يمكن كتابة معادلة تكتب جملة مثل : ناجح ومنقول للصف ..

له دور ثانى فى ..

3- يمكن استخدام Check Boxes بجوار الاختيارات ويتم عمل علامة صح بجوار الحالة الصحيحة .......

[smart]

السلام عليكم

شكرا لك على ردك

ولكن المطلوب هو رسم دائرة حمراء في الشهادة حول حالة الطالب فأنا صممت شهادة ولكن اضطر بعد الانتهاء بوضع الدائرة باليد فعند طرحكم هذ ا الموضوع شعرت بأن بالامكان رسمها حول حالة الطالب وربما يكون اسهل لان حالة الطالب ( ناجح - راسب - مكمل ) قد تم استخراجها في عمود خاص عن طريق دالة if >

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

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

وبارك الله فيكم جميعا نرجو الاهتمام

[smart]

السلام عليكم

اخي العزيز لو تكرمت علينا ممكن مثال بسيط على دالة check box

ولك الشكر

[متعب الفرسان]

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

[حسام نور]

أخي متعب .......... لاحظ هذا السطر في الكود

.Line.ForeColor.RGB = RGB(255, 0, 0)

الرقم 255 هو رقم اللون قم بتغييره مثلاً الي الرقم 100 ثم عد مره أخرى لورقة العمل وقم بتغيير الرقم الي الحد الأعلى ثم الأدنى لتظهر التغيرات ستلاحظ تغير اللون

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

وفقك الله

[متعب الفرسان]

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