الحديثة قام بنشر يونيو 13, 2012 قام بنشر يونيو 13, 2012 هل يمكن عمل مربع بدل الدائرة فى كود الدوائر الحمراء اى عمل مربع على ربع الدرجة ودائرة على على الدرجة للمجموع
عبدالله المجرب قام بنشر يونيو 13, 2012 قام بنشر يونيو 13, 2012 ممكن ذلك فاذا كنت تستخدم كود الاستاذ خبور فالتعديل سيكون في هذا السطر Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)
الحديثة قام بنشر يونيو 13, 2012 الكاتب قام بنشر يونيو 13, 2012 انا استخدم هذا الكود Sub sDrawOval() If TypeName(Selection) <> "Range" Then Exit Sub Dim ssRange As Range Set ssRange = Selection DrawOvals ssRange, 60, 0.1 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 If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value <> "Û" And cCell.Value <> "ÛÜ") Then cCell.Worksheet.Shapes(OvName).Delete End If Else 'If cCell.Value < MinDegree And cCell.Formula <> "" Then If cCell.Value < MinDegree And cCell.Formula <> "" Or (cCell.Value = "Û" Or cCell.Value = "ÛÜ") 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# 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
عبدالله المجرب قام بنشر يونيو 14, 2012 قام بنشر يونيو 14, 2012 سيصبح كودك هكذا ==================== Sub sDrawOval() If TypeName(Selection) "Range" Then Exit Sub Dim ssRange As Range Set ssRange = Selection DrawOvals ssRange, 60, 0.1 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 If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value "غ" And cCell.Value "غـ") Then cCell.Worksheet.Shapes(OvName).Delete End If Else 'If cCell.Value < MinDegree And cCell.Formula "" Then If cCell.Value < MinDegree And cCell.Formula "" Or (cCell.Value = "غ" Or cCell.Value = "غـ") Then MrH = OvMargRatio * cCell.Height MrW = OvMargRatio * cCell.Width OvalW = cCell.Width - MrW OvalH = cCell.Height - MrH Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeRectangle, 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# 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
الحديثة قام بنشر يونيو 14, 2012 الكاتب قام بنشر يونيو 14, 2012 بيطلع خطاء فى السطر If (cCell.Value >= MinDegree Or cCell.Formula = "") And (cCell.Value "Û" And cCell.Value "ÛÜ") Then
الحديثة قام بنشر يونيو 14, 2012 الكاتب قام بنشر يونيو 14, 2012 استاذى عبد الله المجرب بعد التحية والاحترام ام اتوصل الى الحل ولكن اليك المرفك اريد مربع على درجة الترم الثانى اذا كان اقل من 15 درجة ومجموع العربى لو اقل من 40 دائرة الثالث.rar
عبدالله المجرب قام بنشر يونيو 14, 2012 قام بنشر يونيو 14, 2012 السلام عليكم اليك ملفك وقد اضفت اليه كود الاستاذ خبور للدوائر وهو الافضل من وجهة نظري جرب المرفق واعلمني بالنتيجة الثالث.rar
الحديثة قام بنشر يونيو 14, 2012 الكاتب قام بنشر يونيو 14, 2012 (معدل) استاذى العزيز لك منى كل تقدير واحترام واشكرك على سعة صدرك وعلمك الذى افادنى كثيرا ولى طلب لو طبقنا هذا على الورقة 1 بحيث يضع على درجة الترم 2 مربع اذا كانت اقل من 15 درجة اما فى مجموع الدرجة للمادة يكون عليها دائرة بمعنى استعمل كود لدرجة ربع الدرجة فى الترم 2 يكون مربع وكود للدرجة المادة اقل من 40 درجة فى العربى يضع دائرة هل هذا ممكن باى طريقة تم تعديل يونيو 14, 2012 بواسطه الحديثة
الحديثة قام بنشر يونيو 14, 2012 الكاتب قام بنشر يونيو 14, 2012 او ممكن شرح كود الاستاذ خبور اوشرح كود زرع الدالة ولكم جزيل الشكر
الحديثة قام بنشر يونيو 14, 2012 الكاتب قام بنشر يونيو 14, 2012 استاذى العزيز المحترم اشكرك كثيرا على سعة صدرك واعطاك الله من علمو الكثير نعم هذا ما اقصدة ولكن لا اريد ان يضع دائرة على الترم 1 ويكون هو المطلوب تماما وادعو المولى عز وجل ان يعطيك من بحر علمة الفياض ولك كل شكر وتفدير والاحترام
دغيدى قام بنشر يونيو 14, 2012 قام بنشر يونيو 14, 2012 غير هذا السطر من الكود Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6) بهذا السطر من الكود Set V = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6) بعد إذن أخى الفاضل .. أبو احمد غير السطر الأول بالسطر الثانى لتحصل على مستطيل مستدير الأركان بدلا من قائم الزاوية
ياسر الحافظ قام بنشر يونيو 15, 2012 قام بنشر يونيو 15, 2012 ما شاء الله ماذا نقول " دينمو الموقع + العميـــــــــــــــد " ما شاء الله ماشاء الله ادامكم الله ... ويسر امركم وفقكم الله ابو الحارث
عبدالله المجرب قام بنشر يونيو 15, 2012 قام بنشر يونيو 15, 2012 السلام عليكم تم التعديل كما تم اضافة المريع الدائري بدل القائم الثالث.rar 1
دغيدى قام بنشر يونيو 15, 2012 قام بنشر يونيو 15, 2012 أخى وحبيبى / يــــــاسر عود حميد .. بارك الله فى سورية والسوريين
الحديثة قام بنشر يونيو 15, 2012 الكاتب قام بنشر يونيو 15, 2012 كل الشكر والتقدير والاحترام الى كل من ساهم فى هذه المشاركة واخص بالذكر الاستاذ عبد الله والاستاذ دغيدى و كل اعضاء ومشرفى هذا المنتدى الكرام الذين تعلمنا منهم الكثير وممكن شرح لو بطبق هذا الكود على ملف اخر ما هو المعيار ولكم كل الشكر و التقدير
دغيدى قام بنشر يونيو 15, 2012 قام بنشر يونيو 15, 2012 اخى الفاضل / الحديثة الشكر لك ولكل أعضاء المنتدى الذين يثروا المنتدى بكل ماهو نافع .
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.