[abusarah73]

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 (41.67K)
  عدد مرات التحميل : 18

[خبور خير]

السلام عليكم

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

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 (42.73K)
  عدد مرات التحميل : 10

[abusarah73]

أحسنت يا أستاذ خبور
جزاك الله خير الجزاء
في ميزان حسناتك إن شاء الله

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

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

This post has been edited by abusarah73: 01 August 2010 - 12:32 AM