ربيع قام بنشر يونيو 5, 2004 مشاركة قام بنشر يونيو 5, 2004 كيف عمل دائرة حمراء على الدرجة التي حصل عليها الطالب اقل من 60 درجه رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 10, 2004 مشاركة قام بنشر يونيو 10, 2004 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 رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 10, 2004 مشاركة قام بنشر يونيو 10, 2004 اخي السيد عبد العال السلام عليكم ورحمة الله وبركاته،، قمت بوضع الكود المرفق ولكن لا يعمل دوائر حمراء ارجوا من سيادتكم التوضيح اكثر وشكرا رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 10, 2004 مشاركة قام بنشر يونيو 10, 2004 أخى الفاضل الكود المرفق يقوم برسم قطع ناقص (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 رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 10, 2004 مشاركة قام بنشر يونيو 10, 2004 (معدل) الاستاذ السيد عبد العال السلام عليكم ورحمة الله وبركاته،، شكرا جزيلا على هذا الكود الرائع قمت بتجربته ويعمل ولكن لي استفسار بسيط : كل مره يتم تشغيل الماكرو لكي يقوم برسم الدائرة نريد الكود يعمل مباشرتا بمجرد كتابة الرقم . هناك مشكلة عندما قمت بنسخ الكود لملف جديد يعمل بشكل ممتاز وعندما نسخته في برنامج لديا به اكواد اخرى ونسخه الكود للدائرة لا يعمل هل هناك سبب ساحاول مرة اخرى وهناك ملاحظة ان الدائرة لا تمحى بتغير الدرجة حتى اذا تعدت الدرجة 60 وشكرا جزيلا مع تحياتي لشخصكم الكريم تم تعديل يونيو 10, 2004 بواسطه adel123 رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 11, 2004 مشاركة قام بنشر يونيو 11, 2004 أخى عادل حسين حياكم الله إليكم التعديلات المطلوبة 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 هى نسبة الهامش المتروك بين القطع وحدود الخلية مع تحياتى رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 11, 2004 مشاركة قام بنشر يونيو 11, 2004 السلام عليكم ورحمة الله وبركاته،، الاستاذ السيد عبد العال شكرا جزيلا على الاهتمام وجزاك الله خيراً الكود الاول يعمل بشكل جيد واعتقد ان المعادلة الاخرى به خطأ لانها لا تعمل اخي العزيز نحن نعمل برنامج شهادات للطلاب ولدينا شيت رئيسي به اسماء الطلاب ودرجاتهم للمواد وكما تعلم الدرجات متغيرة اي احيانا تكون فوق 60 او اقل المهم اريد ان الفت نظر سيادتكم انه اريد كود اذا اعطيته درجة اقل من60 تعمل الدائرة واذا غيرت نفس الدرجة من 60الى 40 تمحى الدائرة والعكس اي ان لا تكون الدائرة عند تفعيل الكود تبقى حتى لو تغيرت الدرجة وعلى كل حال اشكر سيادتكم جزيل الشكر وجزاك الله خيراً رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 11, 2004 مشاركة قام بنشر يونيو 11, 2004 السلام عليكم المعادلة الثانية تعتمد على وجود الكود أى بعد نسخ الكود فى module يتم كتابة المعادلة ويتم التعامل معها مثل اى معادلة فى الأكسل ويمكن كتاباتها باحد طريقتين يتم اختيار خانة بعيد ا عن المنطقة التى بها الدرجات و يكتب فيها معادلة شبيهة بهذه: =fDrawOval(B2:J20;60;0.2) مع مراعة تغيير B2:j20 ليصبح هو اسم المنطقة التى بها الدرجاتوكذللك استخدم الفاصلة بدلا من الفاصلة المنقوطة إذا كان نظامك يستلزم ذلك الطريقة الثانية لكتابة الالة هى معالج الدوال من القائمة: Insert -> Function تؤدى الى الى ظهور مربع حوارى نحتار من الصندوق بجوار cateegry User Defined فتظهر الدوال ومنها fDrawOval فيتم إختيارها واسكمال الصندوق الحوارى الخاص بها والذى يظهر فيه مكان لثلاث متغيرات ٍsRange MinDegree OvMargRatio رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 11, 2004 مشاركة قام بنشر يونيو 11, 2004 السلام عليكم ورحمة الله وبركاته،، شكرا جزيلاً استاذي الفاضل على الشرح الجميل سأقوم بتجربة التعديلات الاخيرة واذا هناك اي مشكلة سأوافيك بها . لك من كل التحية والتقدير اخي العزيز رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 11, 2004 مشاركة قام بنشر يونيو 11, 2004 (معدل) السلام عليكم ورحمة الله وبركاته،، شكرا جزيلاً استاذي الفاضل على الشرح الجميل ,وشكرا جدا على الملف الرائع الذي ارسلته لى فهو يعمل كما اردت بالضبط فهو عمل رائع جدا . ساعدني اخي العزيز اريد نسخة بالبرنامج لدي اولا قمت بنسخ module ووضعه بـmodule جديد في برنامجي وايضا المعادلة ولكن لا تعمل ولا اعرف السبب وعلى فكره انا استخدم اوفيس اكس بي سأقوم بالتجربة مره اخرى الى برنامج الشهادات وسأوافيك بالرد لك من كل التحية والتقدير اخي العزيز تم تعديل يونيو 11, 2004 بواسطه adel123 رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 12, 2004 مشاركة قام بنشر يونيو 12, 2004 السلام عليكم وهل تظهر الماكرو المسماة sDrawOval فى قائمة الماكرو؟ وهل تظهر الدالة fDrawOval فى معالج الدوال تحت التصنيف المسمى User Defined? رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 12, 2004 مشاركة قام بنشر يونيو 12, 2004 استاذي الفاضل السلام عليكم ورحمة الله وبركاته،، بالنسبة للماكرو sDrawOval فهو يظهر بقائمة الماكرو اما بالنسبة للدالة fDrawOval فهي موجوده في شريط الصيغة fx اما بالنسبة الى معالج الدوال عذراً اخي العزيز اين اجدها . fDrawOval موجوده بوسائط الدالة هل هو معالج الدوال ام لا . في انتظار تعليق سيادتكم ان شاء الله تحل المشكلة ولسيادتكم جزيل الشكر على اهتمامكم جزاك الله خيرا لك من كل التحية والتقدير رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 13, 2004 مشاركة قام بنشر يونيو 13, 2004 السلام عليكم إذا كان اسم الماكرو يظهر فى اسماء الماكرو هذا يعنى انك تستطيع استدعائها فماذا يحدث عندما تختار الخلايا التى بها الدرجات ثم تشغل الماكرو؟ هل تحصل على رسالة خطأ؟ وعموما اذا نجحنا فى تشغيل الماكرو فسننج بإذن الله فى تشغيل الدالة. اما معالج الدوال اقصد به الصندوق الحوارى الذى يظهر عند ضغط Insert Function ويظهر فيه تقسم الدوال إلى مجموعات رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 13, 2004 مشاركة قام بنشر يونيو 13, 2004 السلام عليكم ورحمة الله وبركاته،، استاذي الفاضل كل ما تفضلتم به سيادتكم موجود وصحيح الماكرو والدالة ولا تظهر اي رسائل عند تشغيل الماكرو وعلى فكرة المشكلة فقط تظهر معي عند محاولة نسخ الكود والدالة بالبرنامج الذي قمت باعداده اما اذا فتحت ملف جديد وقمت بنسخ الماكرو والدالة فهي تعمل بأمتياز ودون اي اخطاء المشكلة انه لا يعمل بالبرنامج الخاص بي وهو برنامج شهادات يحتوي على الكثير من الماكروهات والدوال واذا اضفت الماكرو الخاص بالدائر الحمراء والدالة فيه لا تعمل فلا اعلم السبب . اسف سيدي على كثرة الاسئلة فيه محيرة تعمل في مكان ولا تعمل في مكان اخر اعلم ان حل المشكلة اكيد بسيطة ولكن اين هي ! تقبل سيدي من كل التحية والتقدير رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 14, 2004 مشاركة قام بنشر يونيو 14, 2004 أخى الفاضل السلام عليكم ورحة الله أرجو التجربة مرة أخرى بعد هذا التعديل الطفيف ربما يحل المشكلة مرفق ملف به تطبيق للدالة. تم تعديل الملف فى مشاركة لاحقة رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 14, 2004 مشاركة قام بنشر يونيو 14, 2004 السلام عليكم ورحمة الله وبركاته،، هناك خطأ بالكود عند فتح الملف يعطي رسالة compile error ارجو المعذره اخي العزيز رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 14, 2004 مشاركة قام بنشر يونيو 14, 2004 معذرة يا أخى إليك الملف الصحيح ovs4xp.zip رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 14, 2004 مشاركة قام بنشر يونيو 14, 2004 السلام عليكم ورحمة الله وبركاته،، استاذي الفاضل قمت بتنفيذ كل ما تفضلتم به دون جدوى وسأرفق لسيادتكم الملف الذي لا يعمل دوائر مع انني نسخت الكود والمعادلة وايضا شيت اخر بنفس الملف الكود يعمل بشكل ممتاز ما الفرق بين الورقتين لا اعلم لملذا يعمل الكود في مكان ومكان اخر لا يستجيب الى سيادتكم الملف للاطلاع وشكرا جزيلا استاذي الفاضل http://www.emiratesvoice.com/imagecenter/pic/adel_6.zip رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 14, 2004 مشاركة قام بنشر يونيو 14, 2004 أخى الفضل قبل كل شئ أحب أن أحيك على مستوى العمل الذى قمتم به فإخراجه جميل ثانيا: إليكم ماكرو أخرى أضافة إلى الماكروهات السابقة وهى تقوم بمسح جميع الدوائر فى الشيت النشطة عند استدعائها 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 فى نفس مكانه من الصف ذو الخلايا الصفراء وبالتالى تقوم الدوال بالرسم مرة أخرى يكرر العمل السابق لكل الشيتات ولكم تحياتى والسلام عليكم ورحمة الله رابط هذا التعليق شارك More sharing options...
حسام نور قام بنشر يونيو 15, 2004 مشاركة قام بنشر يونيو 15, 2004 تحيه على هذا العمل الرائع رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 15, 2004 مشاركة قام بنشر يونيو 15, 2004 (معدل) السلام عليكم ورحمة الله وبركاته،، استاذي الفاضل شكرا جزيلا اخيرا تم حل المشكلة والدوائر تعمل بشكل ممتاز وذلك بعد ما تفضلتم به سيادتكم من تعديل وتوضيح وفعلا عندما تم تحويل Zoom الى 100% قام الكود بالعمل وقد كنت ضبط Zoom على 40% لكبر الصفحة ولكن ليست مشكلة بعد الانتهاء من العمل نقوم بالضبط الى 100% لكي تعمل الدوائر وعلى فكرة عند ارجاع الـ Zoom الى 40 مره اخرى وقمت بالتعديل فالدوائر لا تعمل المهم انها مشكلة بسيطة والحمد لله على حل المشكلة وشكراً جزيلاً وجزاك الله خيراً على هذا العمل الرائع استاذي الفاضل لك مني تحية طيبة وكل الاحترام وشكراً تم تعديل يونيو 15, 2004 بواسطه adel123 رابط هذا التعليق شارك More sharing options...
محمد طاهر عرفه قام بنشر يونيو 15, 2004 مشاركة قام بنشر يونيو 15, 2004 عمل ممتاز ، و مثال مميز جدا جزاك الله خيرا رابط هذا التعليق شارك More sharing options...
السيد عبد العال قام بنشر يونيو 16, 2004 مشاركة قام بنشر يونيو 16, 2004 الأخ الاستاذ حسام نور الأخ الاستاذ عادل حسين الأخ المهندس / محمد طاهر جزاكم الله خيرا على هذا التشجيع لازلت هناك مشكلة لم أطرحها بعد لانشغالنا بالمشكلة السابقة: Bug: ماذا يحدث للدالة fDrawOval() عند حذف أوإضافة خلايا اوصفوف أو أعمدة من ال Range المحدد فى متغيراتها؟ رابط هذا التعليق شارك More sharing options...
adel123 قام بنشر يونيو 16, 2004 مشاركة قام بنشر يونيو 16, 2004 السلام عليكم ورحمة الله وبركاته،، الاستاذ الفاضل / السيد عبد العال تحية طيبة وبعد بعد نسخ التعديلات الاخيره على البرنامج الخاص بالشهادات تم رسم الدوائر دون اي مشاكل ولكنني لاحظ شي مقلق جدا بالبرنامج حيث ان شهادة الطالب بها قائمة منسدلة لعرض اسماء الطلاب من الشيت الرئيسي وعند استعراض الاسماء بعد فترة قصيرة جدا يتعطل البرنامج بالكامل ويعطي رسالة ( صادف الاكسل مشكلة ويجب اغلاقة ) وطبعا قمت بتجربته اكثر من مرة وعند حذف كود الدوائر لا تظهر هذه المشكلة . تحية طيبة استاذي العزيز ونأسف عن الازعاج رابط هذا التعليق شارك More sharing options...
ابومؤنس قام بنشر يونيو 16, 2004 مشاركة قام بنشر يونيو 16, 2004 السلام عليكم ورحمة الله وبركاتة , بعد اذن الاخ سيد عبد العال اذا كان وجود الماكرو الاخير هو سبب المشكلة يمكنك الاستفادة من خاصية عمل الماكرو علي كل المصنفات المفتوحة , فمثلا . اذا كان لديك ماكروا وجعلت من ضمن خصائصة العمل في جميع الصفحات المفتوحة فانة يعمل حتي المصنفات الاخر التي غير متواجد عليها بشرط ان يكون كل من المصنفان مفتوحان في نفس الوقت . وهي الخاصية قد تغني عن نسخ الماكروا الي كل المصنفات المتشابة اذا اردت القيام بنفس العمل . اتمني لك كل التوفيق ,,,, رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان