اذهب الي المحتوي
أوفيسنا

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

الحديثة

بواسطه الحديثة
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

عبدالله المجرب

عبدالله المجرب

قام بنشر
قام بنشر

ممكن ذلك

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


Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6)

رابط هذا التعليق
شارك
الحديثة

الحديثة

قام بنشر
  • الكاتب
قام بنشر

انا استخدم هذا الكود

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

رابط هذا التعليق
شارك
عبدالله المجرب

عبدالله المجرب

قام بنشر
قام بنشر

سيصبح كودك هكذا

====================

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

رابط هذا التعليق
شارك
الحديثة

الحديثة

قام بنشر
  • الكاتب
قام بنشر

استاذى عبد الله المجرب

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

ام اتوصل الى الحل

ولكن اليك المرفك اريد مربع على درجة الترم الثانى اذا كان اقل من 15 درجة ومجموع العربى لو اقل من 40 دائرة

الثالث.rar

رابط هذا التعليق
شارك
عبدالله المجرب

عبدالله المجرب

قام بنشر
قام بنشر

السلام عليكم

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

وهو الافضل من وجهة نظري

جرب المرفق واعلمني بالنتيجة

الثالث.rar

رابط هذا التعليق
شارك
الحديثة

الحديثة

قام بنشر
  • الكاتب
قام بنشر (معدل)

استاذى العزيز

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

واشكرك على سعة صدرك وعلمك الذى افادنى كثيرا

ولى طلب لو طبقنا هذا على الورقة 1 بحيث يضع على درجة الترم 2 مربع اذا كانت اقل من 15 درجة اما فى مجموع الدرجة للمادة يكون عليها دائرة بمعنى استعمل كود لدرجة ربع الدرجة فى الترم 2 يكون مربع وكود للدرجة المادة اقل من 40 درجة فى العربى يضع دائرة هل هذا ممكن باى طريقة

تم تعديل بواسطه الحديثة
رابط هذا التعليق
شارك
الحديثة

الحديثة

قام بنشر
  • الكاتب
قام بنشر

استاذى العزيز المحترم

اشكرك كثيرا على سعة صدرك واعطاك الله من علمو الكثير

نعم هذا ما اقصدة ولكن لا اريد ان يضع دائرة على الترم 1 ويكون هو المطلوب تماما

وادعو المولى عز وجل ان يعطيك من بحر علمة الفياض

ولك كل شكر وتفدير والاحترام

رابط هذا التعليق
شارك
دغيدى

دغيدى

قام بنشر
قام بنشر

غير هذا السطر من الكود


 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)

بعد إذن أخى الفاضل .. أبو احمد

غير السطر الأول بالسطر الثانى لتحصل على مستطيل مستدير الأركان بدلا من قائم الزاوية

رابط هذا التعليق
شارك
الحديثة

الحديثة

قام بنشر
  • الكاتب
قام بنشر

كل الشكر والتقدير والاحترام

الى كل من ساهم فى هذه المشاركة واخص بالذكر الاستاذ عبد الله والاستاذ دغيدى و كل اعضاء ومشرفى هذا المنتدى الكرام الذين تعلمنا منهم الكثير

وممكن شرح لو بطبق هذا الكود على ملف اخر ما هو المعيار

ولكم كل الشكر و التقدير

رابط هذا التعليق
شارك
  • 2 years later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept