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

وضع كود الدوائر الحمراء بالملف المرفق

فايز فراج

بواسطه فايز فراج
في منتدى الاكسيل Excel

 مشاركة

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

فايز فراج

فايز فراج

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

السلام عليكم

أرجوا من حضراتكم .. وضع كود مناسب للدوائر الحمراء في ورقة "شيت " بالملف المرفق .. بدلاً من استخدام خاصية " التنسيق الشرطي " .. على أن تكون وضع الدوائر الحمراء في الآتي :

1- عمود .. الفصل الثاني لكل مادة

2 . عمود .. مجموع الفصلين لكل مادة 

برجاء من فضلكم  .. وضع شرح مبسط لكيفية وضع زر الكود 

شيت كنترول الصفين الرابع والخامس الإبتدائي.rar

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

ابراهيم الحداد

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

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

انسخ هذا الكود و الصقه فى موديول و خصص له زر

كما يلى :

من قائمة  insert   ---------- Devolper

ثم اضغط على زر من القائمة المنسدلة ورابطه بالكود السابق كما ارجو ان تقوم بازالة التنسيق الشرطى كى ترى الدوائر 

Sub Circles()
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range
Set ws = Sheets("شيت")
If LR < 14 Then LR = 14
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
Arr = Array(10, 11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)
For R = 14 To LR
For i = LBound(Arr) To UBound(Arr)
For Each Cel In ws.Cells(R, Arr(i))
If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

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

جزاك الله كل خير الاستاذ المحترم زيزو

كتب الله اعمالك في كفة موازينك الطيبه

وبعد

نريد في هذا الكود السريع سطر لمسح الدوائر ان كانت موجوده اولا ثم اضافه الدوائر على نضيف

وكود اخر منفصل لمسح الدوائر فقط

  • Like 1
رابط هذا التعليق
شارك
ابراهيم الحداد

ابراهيم الحداد

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

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

كود مسح الدوائر 

Sub DeletingShp()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
 If shp.Type = msoAutoShape Or shp.Type = msoShapeOval Then shp.Delete
Next
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

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

جزاك الله كل خير استاذ زيزو

ربنا يبارك فيك

ولكن عند استخدام زر المسح يتم حذف الزر نفسه ... هل من حل ؟

وهل يمكن دمج كود الدوائر مع كود المسح بمعنى عند الضغط على زر الدوائر يتم المسح اولا ثم بعدها تضاف الدوائر

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

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

وهل يمكن دمج كود الدوائر مع كود المسح بمعنى عند الضغط على زر الدوائر يتم المسح اولا ثم بعدها تضاف الدوائر

جزاك الله كل خير وبارك فيك استاذ زيزو

عند التجربه اصبح زر المسح لايعمل

  • Like 1
رابط هذا التعليق
شارك
ابراهيم الحداد

ابراهيم الحداد

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

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

استخدم الكود التالى لمسح الدوائر

و استخدم زر " Button" بدلا من استخدام الشكل التلقائى 

Sub DeletingShp()
    Dim shp As Shape, x As Long
    For Each shp In ActiveSheet.Shapes
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
MsgBox "تم حذف   " & x & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub

 

  • Like 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

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

اكمل جميلك واشرح الاسطر الباقيه يحفظك الله ويرعاك استاذ زيزو 

Sub Circles()
'هذا الكود للمحترم النابغه زؤزو العجوز
'الهدف من الكود هو وضع دوائر على درجات  في اعمده معينه
'تم هذا الكود في 19/5/2017

'استدعاء كود المسح اولا
Call DeletingShp

'متغيرات
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'اسم صفحه العمل
Set ws = Sheets("شيت")

If LR < 14 Then LR = 14

'متغير لعد الصفوف
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ارقام الاعمده المطلوب وضع دوائر فيها
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'بدايه الصفوف
For R = 14 To LR
For i = LBound(Arr) To UBound(Arr)
For Each Cel In ws.Cells(R, Arr(i))

If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  
Sub DeletingShp()
    Dim shp As Shape, x As Long
    For Each shp In ActiveSheet.Shapes
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
'MsgBox "تم حذف   " & x & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub

 

ملف الكودين للمحترم زيزو العجوز ( الكود الاول لوضع الدوائر والكود الثاني لمسح الدوائر )

نسخه منقحه

الدوائر.rar

  • Like 2
رابط هذا التعليق
شارك
ابراهيم الحداد

ابراهيم الحداد

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

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

اخى الكريم اليك ماطلبت ارجو من الله عز وجل ان يكون الشرح واضح 

Sub Circles()
'استدعاء كود المسح اولا
Call DeletingShp

'متغيرات
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'اسم صفحه العمل
Set ws = Sheets("شيت")
  ' هذا شرط الا يعمل الكود قبل الصف 14
If LR < 14 Then LR = 14

'متغير لعد الصفوف
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ارقام الاعمده المطلوب وضع دوائر فيها
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'بدايه الصفوف
For R = 14 To LR
  ' عرض المصفوفة الخاصة بالاعمدة
For i = LBound(Arr) To UBound(Arr)
  ' نطاق تطبيق الامر وهو الخاص برسم الدوائر
For Each Cel In ws.Cells(R, Arr(i))
  '  الشرط الذى على اساسه سوف يتم رسم الدوائر
If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then 
  ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية 
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)
  ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  '    الكود الثانى
Sub DeletingShp() 
   ''  المتغيرات
    Dim shp As Shape, x As Long
     ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها
    For Each shp In ActiveSheet.Shapes
   '   امر المسح
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
   '    رسالة بعدد الدوائر التى تم مسحها
'MsgBox "تم حذف   " & x & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub

 

  • Like 2
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

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

الكود اخذ حقه  ... يحفظك ربنا ويرعاك الاستاذ زيزو العجوز

استخدم الكود التالى لمسح الدوائر

و استخدم زر " Button" بدلا من استخدام الشكل التلقائى 

Sub Circles()
'هذا الكود للمحترم النابغه زيزو العجوز
'الهدف من الكود هو وضع دوائر على درجات  في اعمده معينه
'تم هذا الكود في 19/5/2017

'استدعاء كود المسح اولا
Call DeletingShp

'متغيرات
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'اسم صفحه العمل
Set ws = Sheets("شيت")

  ' هذا شرط الا يعمل الكود قبل الصف 14
If LR < 14 Then LR = 14

'متغير لعد الصفوف
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ارقام الاعمده المطلوب وضع دوائر فيها
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'بدايه الصفوف
For R = 14 To LR

  ' عرض المصفوفة الخاصة بالاعمدة
For i = LBound(Arr) To UBound(Arr)

  ' نطاق تطبيق الامر وهو الخاص برسم الدوائر
For Each Cel In ws.Cells(R, Arr(i))

  '  الشرط الذى على اساسه سوف يتم رسم الدوائر
If Cel.Value < ws.Cells(13, Cel.Column) Or Cel.Value = "غ" Then

  ' مواصفات الشكل وهو هنا عبارة عن دائرة وما بين الاقواس هو ابعاد الدائرة حتى لا تصبح اكبر من حجم الخلية
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)

  ' مواصفات الدائرة من حيث درجة اللون وحجم الخط و الشفافية
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  '    الكود الثانى
Sub DeletingShp()

   ''  المتغيرات
    Dim shp As Shape, x As Long
    
     ' هذا النطاق يسمح بمسح كل الاشكال فى ورقة العمل سواء دائرة او غيرها
    For Each shp In ActiveSheet.Shapes
    
   '   امر المسح
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
   '    رسالة بعدد الدوائر التى تم مسحها
'MsgBox "تم حذف   " & x & "   دائرة بنجاح", vbMsgBoxRight, "الحمدلله"
End Sub

 

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

 

كود الدوائر وكود مسحها.rar

  • Like 1
رابط هذا التعليق
شارك

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

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



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

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

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

Important Information

  I accept