تعديل على الكود لإظهار مسج بوكس

[أبوســـارة1973]

Private Sub Worksheet_Change(ByVal Target As Range)


Dim R As Integer, C As Integer

If Not Intersect(Target, Range("E8:AN78")) Is Nothing Then

    Application.ScreenUpdating = False

    C = Target.Column

    For R = 8 To 78

        If Cells(R, C) <> "" And Application.CountIf(Range(Cells(8, C), Cells(80, C)), Cells(R, C)) > 1 Then

            Cells(R, C).Interior.ColorIndex = 39

       Else

            Cells(R, C).Interior.ColorIndex = xlNone

        End If

    Next

    Application.ScreenUpdating = True

End If

End Sub

هذا الكود يقوم بتلوين الخلايا التي يتم فيها إدخال الصف لأكثر من مرة في نفس الحصة ( العمود )

والمطلوب إضافة تعديل عليه ليظهر رسالة ( مسج بوكس ) من نوع yesno في حال إدخال صف تم إدخاله من قبل في نفس الحصة ( العمود) مفادها (" ثم إسناد هذا الصف لمعلم آخر ....... هل تريد المتابعة ؟"

الضغط على yes يفعل الكود ( تلوين الخليتين الأولى والثانية وكل الخلايا التي تحمل نفس الصف )

والضغط على no يجعل الخلية النشطة فارغة ( الخلية النشطة يعني نفس الخلية التي جرت عليه العملية )

مع خالص شكري وتقديري للجميع

abusarah73-22.rar

[عبدالله باقشير]

السلام عليكم

جرب الكود التالي:

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

Dim CC As Integer, C As Integer

Dim sR As String

Dim MyRng As Range

Set MyRng = Range("E8:AN78")

If Not Intersect(Target, MyRng.Cells) Is Nothing Then

    Application.EnableEvents = False

    CC = MyRng.Column - 1

    C = Target.Column - CC

    sR = MyRng.Columns(C).Address

    If Application.CountIf(Range(sR), Target.Value) > 1 Then

        If MsgBox("تم إسناد هذا الصف لمعلم آخر ......." & vbLf & vbLf & "هل تريد المتابعة ؟", 16 + vbYesNo + 524288 + 1048576, "تاكيد") = vbNo Then

            Target.ClearContents

        End If

    End If

    Kh_ColorIndex Range(sR)

    Application.EnableEvents = True

End If

On Error GoTo 0

End Sub

-----------------------------------------


Private Sub Kh_ColorIndex(Mycel As Range)

Dim cel As Range

Application.ScreenUpdating = False

For Each cel In Mycel

    If cel <> "" And Application.CountIf(Mycel, cel) > 1 Then

        cel.Interior.ColorIndex = 39

    Else

        cel.Interior.ColorIndex = xlNone

    End If

Next

Application.ScreenUpdating = False

End Sub

مرفق ملف

خبور خير

abusarah73-22.rar

[أبوســـارة1973]

أحسنت يا أستاذ خبور

جزاك الله خير الجزاء

في ميزان حسناتك إن شاء الله

نعم أنت دائما من يتصدى لمثل هذه الطلبات

هل بالإمكان أن يحدد المعلم الذي أسند له الصف في المسج بوكس بدلاً من عبارة ( معلم آخر) ؟

أسأل الله لك رزقا واسعا ذنبا مغفورا وحاجة مقضية وهموما مكفية .

تم تعديل يوليو 31, 2010 بواسطه abusarah73