مساعدة فى تعديل كود

[بوحماد]

مساعدة فى تعديل كود الدوئر اكود يعمل تمام لاكن فية مشكلة بسيطة وهى وضع الدوئر على الاسطر التى لايوجد فيها بيانات نريد لايوضع دوئر عندما لايوجد بيانات للطالب ستلاحظ فى المرفق الدوئر الموجودة على القيمة الصفر مرفق الملف

61.rar

[بوحماد]

هذا هو الكود

Sub Start_Circles()

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 = 5      '    ÚãæÏ ãÌãæÚ ÇáÝÕáíä

R = 13       '    ÕÝ ÇáÏÑÌÇÊ

Set MyRng = Range("g17:ar1000")  ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ

'================================================

X = ActiveWindow.Zoom

Application.ScreenUpdating = False

Call Remove_Circles

ActiveWindow.Zoom = 100

For Each C In MyRng

       If Cells(C.Row, G) <> "&atilde;&Igrave;&atilde;&aelig;&Uacute; &Ccedil;&aacute;&Yacute;&Otilde;&aacute;&iacute;&auml; " Then GoTo 1

       If Cells(C.Row, G) = 0 Or Cells(C.Row, G) = " " 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.Value = "&Ucirc;" Or C.Value = "&Ucirc;&Uuml;") And C.Value <> "" Then

    Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)

        V.Fill.Visible = msoFalse

        V.Line.ForeColor.SchemeColor = 10

        V.Line.Weight = 2

        D = D + 1

    End If

1 Next

ActiveWindow.Zoom = X

Application.ScreenUpdating = True

MsgBox "&Ecirc;&atilde; &Aring;&Ouml;&Ccedil;&Yacute;&Eacute;   " & D & "   &Iuml;&Ccedil;&AElig;&Ntilde;&Eacute; &Egrave;&auml;&Igrave;&Ccedil;&Iacute;", vbMsgBoxRtlReading, "&Ccedil;&aacute;&Iacute;&atilde;&Iuml;&aacute;&aacute;&aring;"

Set MyRng = Nothing

End Sub

Sub Remove_Circles()

    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 "&Ecirc;&atilde; &Iacute;&ETH;&Yacute;   " & D & "   &Iuml;&Ccedil;&AElig;&Ntilde;&Eacute; &Egrave;&auml;&Igrave;&Ccedil;&Iacute;", vbMsgBoxRtlReading, "&Ccedil;&aacute;&Iacute;&atilde;&Iuml;&aacute;&aacute;&aring;"

End Sub

[عبد الفتاح كيرة]

تفضل

السطر رقم 15

Sub Start_Circles()

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 = 5      '    ÚãæÏ ãÌãæÚ ÇáÝÕáíä

R = 13       '    ÕÝ ÇáÏÑÌÇÊ

Set MyRng = Range("g17:ar1000")  ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ

'================================================

X = ActiveWindow.Zoom

Application.ScreenUpdating = False

Call Remove_Circles

ActiveWindow.Zoom = 100

For Each C In MyRng

       If C = 0 Then GoTo 1

       If Cells(C.Row, G) <> "ãÌãæÚ ÇáÝÕáíä " Then GoTo 1

       If Cells(C.Row, G) = 0 Or Cells(C.Row, G) = " " 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.Value = "Û" Or C.Value = "ÛÜ") And C.Value <> "" Then

    Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)

        V.Fill.Visible = msoFalse

        V.Line.ForeColor.SchemeColor = 10

        V.Line.Weight = 2

        D = D + 1

    End If

1 Next

ActiveWindow.Zoom = X

Application.ScreenUpdating = True

MsgBox "Êã ÅÖÇÝÉ   " & D & "   ÏÇÆÑÉ ÈäÌÇÍ", vbMsgBoxRtlReading, "ÇáÍãÏááå"

Set MyRng = Nothing

End Sub

Sub Remove_Circles()

    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

If C = 0 Then GoTo 1

لكن ممكن طالب يكون مجموع درجاته صفرا

الدوائر الحمراء-kemas.rar

[بوحماد]

مشكوررررررر استاذناkemas على راد السريع وبارك الله فيك