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

فايز فراج · مايو 17, 2017

السلام عليكم

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

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

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

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

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

**ابراهيم الحداد** · مايو 17, 2017

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

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

كما يلى :

من قائمة 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

**ناصر سعيد** · مايو 17, 2017

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

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

وبعد

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

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

**ابراهيم الحداد** · مايو 18, 2017

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

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

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

**ناصر سعيد** · مايو 18, 2017

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

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

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

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

**ابراهيم الحداد** · مايو 18, 2017

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

استبدل هذه العبارة

If shp.Type = msoAutoShape Or shp.Type = msoShapeOval Then shp.Delete

بهذه العبارة

If  shp.Type = msoShapeOval Then shp.Delete

**ناصر سعيد** · مايو 18, 2017

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

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

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

**ابراهيم الحداد** · مايو 18, 2017

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

نعم اخى العزيز

ضع هذه العبارة فى بداية الكود الاول

Call DeletingShp

**ناصر سعيد** · مايو 18, 2017

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

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

**ابراهيم الحداد** · مايو 19, 2017

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

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

و استخدم زر " 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

**ناصر سعيد** · مايو 19, 2017

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

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

**ابراهيم الحداد** · مايو 19, 2017

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

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

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

**ناصر سعيد** · مايو 19, 2017

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

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

و استخدم زر " 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

تسجيل الدخول

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

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

فايز فراج

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

ناصر سعيد

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

ناصر سعيد

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

ناصر سعيد

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

ناصر سعيد

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

ناصر سعيد

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

ناصر سعيد

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information