اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

مطلوب تعديل كود دوائر فى صفحة الراسبين


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

السلام عليكم أساتذتنا الأفاضل

مرفق كود لأحد الأفاضل الغاليين المتميزين بالمنتدى المحترم

الكود يعمل جيداً و المطلوب تعديل بسيط عليه

فكرة الكود وضع دائرة فى خلية الدرجة النهائية للمادة إذا كانت أقل من درجة النجاح

المطلوب إضافة شرطين فى الكود ليضع دائرة فى نفس الخلية حتى لو كانت بها درجة أعلى من درجة النجاح إذا كانت خلية أخرى فى نفس السطر بها أحد الشرطين التاليين

1. أن تكون بها حرف غ

2. أن تكون بها درجة أقل من 21

 ومرفق الملف التجريبى و يحتوى على الكود المرفق

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       RemoveCircles1
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
Dim C As Range
Dim MyRng As Range, V As Shape
Dim X As Integer, G As Integer, R As Integer, D As Integer
'================================================
G = 2       '    عمود رقم الجلوس
R = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" Then GoTo 1
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 Next


ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub
Sub RemoveCircles1()
    Dim shp As Shape, D As Integer
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete: D = D + 1
    Next shp
MsgBox "تم حذف   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

 

تجربة تعديل كود دوائر.xls

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

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

اجعل الكود هكذا

Sub Circles1()
Dim C As Range
Dim MyRng As Range, V As Shape
Dim X As Integer, G As Integer, R As Integer, D As Integer
'================================================
G = 2       '    عمود رقم الجلوس
R = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" Then GoTo 1
    On Error Resume Next
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) _
    Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -3).Value < Cells(R, C.Column - 3) _
    Or C.Offset(0, -3).Value Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 Next


ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

 

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

بارك الله فيك أستاذنا الفاضل ولكن هناك ملحوظة في السطر

 Or C.Offset(0, -3).Value  Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then

سهوًا  لم تكتب شرط = "غ"

فيصبح

 Or C.Offset(0, -3).Value = "غ" Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then

حتى يعمل الكود بشكل سليم 

فالكود بعد التصويب

وجزاك الله خيرًا  وجعله في ميزان حسناتك

Sub Circles1()
Dim C As Range
Dim MyRng As Range, V As Shape
Dim X As Integer, G As Integer, R As Integer, D As Integer
'================================================
G = 2       '    عمود رقم الجلوس
R = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" Then GoTo 1
    On Error Resume Next
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) _
    Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -3).Value < Cells(R, C.Column - 3) _
     Or C.Offset(0, -3).Value = "غ" Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
       D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 Next


ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

 

 

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

الاستاذ الفاضل ابراهيم الحداد
بعد التحية
الكود الذى أرفقته سيادتكم يعطينى إرور
ولا يعمل
و مرفق الملف وبه الكود

تعديل ابراهيم.xls

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

الاستاذ الفاضل أحمد بدرة
تحية طيبة
الف شكر لتعبك معانا

الكود الذى أرفقته حضرتك يقوم بوضع الدوائر و لكنه لا يحذفها 

أرجو إضافة خاصية الحذف التى كانت موجودة فى الكود الأصلى

حيث كان زر الكود تظهر عليه كلمة إضافة الدوائر عندما تكون الدوائر مش موجودة
و تظهر عليه كلمة حذف الدوائر عندما تكون الدوائر موجودة

ومرفق الملف به الكود

الف شكر مرة أخرى
 

تعديل أحمد.rar

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

أستاذ يوسف عطا  كل ما عملته هو أنه لاحظت كود أستاذنا الفاضل الأستاذ إبراهيم لا يعمل ووجدت السبب الذي يجعله لا يعمل

فالملف الذي أرفقته في الملف التجريب به عدد 3 ماكرو  أحدهم يجمع عمل كودين بحيث إذا تم تشغيل كود الدوائر يظهر  كود حذف الدوائر بالتبادل 

و تم التعديل  بإضافة الكود الذي يجعمل الكودين وكود الحذف وإليك الملف بعد التعديل

 

تعديل أحمد.rar

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information