رسالة تنبيه عند الادخال

[عادل ابوزيد]

السلام عليكم

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

المطلوب:

عند ادخال رقم الحالة وهذه الحالة سبق ادخالها يتم التاكد من اتخاذ اجراء فيها من خلال الاعمدة K & L &M & N

بمعنى على سبيل المثال اذا كانت الخانات امام الادخال الاول فى هذه الاعمدة ممتلئة فيقبل كتابة الحالة اما إذا كانت فارغة فلا يقبل وتظهر رسالة انه سبق الادخال ولم يتخذ اجراء 

مع العلم انه ممكن الحالة تكتب اكثر من 10 مرات طالما اتخذ فيها اجراء فلا مشكلة من الادخال مرة اخرى 

تقبلوا تحياتى واحترامى

Book1.rar

[Foksh]

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

تفضل هذه الفكرة :-

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, valToCheck, foundCell As Range
    
    On Error Resume Next
    Set c = Intersect(Target, Columns("E"))
    If c Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    valToCheck = c.Value
    If valToCheck <> "" Then
        Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues)
        
        If Not foundCell Is Nothing And foundCell.Row <> c.Row Then
            If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then
                MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه"
                c.ClearContents
            End If
        End If
    End If
    
    Application.EnableEvents = True
End Sub

 

Book1.zip

[عادل ابوزيد]

السلام عليكم 

الاستاذ الفاضل Foksh جزاك الله كل خير الحل جميل وبسيط .. ولى استفسار الملف الاصل به كود عند ادخال رقم الحالة يقوم ايضا بادراج تاريخ اليوم فى خانة التاريخ فهل يمكن دمج الكودين فى كود واحد 

تقبل تحياتى وشكرى وتقديرى

[Foksh]

4 ساعات مضت, عادل ابوزيد said:

السلام عليكم 

الاستاذ الفاضل Foksh جزاك الله كل خير الحل جميل وبسيط .. ولى استفسار الملف الاصل به كود عند ادخال رقم الحالة يقوم ايضا بادراج تاريخ اليوم فى خانة التاريخ فهل يمكن دمج الكودين فى كود واحد 

تقبل تحياتى وشكرى وتقديرى

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

لم اجد الكود الذي تتحدث عنه ،ولكن قم بالتعديل للدالة التي في الملف السابق الى التالي :-

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, valToCheck, foundCell As Range
    Dim duplicateFound As Boolean
    
    On Error Resume Next
    Set c = Intersect(Target, Columns("E"))
    If c Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    valToCheck = c.Value
    If valToCheck <> "" Then
        Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues)
        
        If Not foundCell Is Nothing And foundCell.Row <> c.Row Then
            If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then
                MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه"
                c.ClearContents
                duplicateFound = True
            End If
        End If
        
        If Not duplicateFound Then
            Cells(c.Row, "D").Value = Date
        End If
    End If
    
    Application.EnableEvents = True
End Sub

 

وأخبرني بالنتيجة