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

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

السلام عليكم

فى الملف المرفق يتم كتابة رقم الحالة فى العمود 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

 

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

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

السلام عليكم 

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

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

Book1.rar

[Foksh]

22 دقائق مضت, عادل ابوزيد said:

السلام عليكم 

 

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

تمام فهمتك ، جرب التعديل ده :-

 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, valToCheck As Variant
    Dim duplicateFound As Boolean
    Dim lastRow As Long, i As Long
    
    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
        lastRow = Cells(Rows.Count, "E").End(xlUp).Row
        duplicateFound = False
        
        For i = 1 To lastRow
            If i <> c.Row And Cells(i, "E").Value = valToCheck Then
                If WorksheetFunction.CountBlank(Range("K" & i & ":N" & i)) = 4 Then
                    MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه"
                    c.ClearContents
                    duplicateFound = True
                    Exit For
                End If
            End If
        Next i
        
        If Not duplicateFound Then
            Cells(c.Row, "D").Value = Date
        End If
    End If
    
    Application.EnableEvents = True
End Sub

 

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

استاذنا الفاضل Foksh

جزاك الله كل خير وجعله فى ميزان حسناتكم برجاء قبول شكرى وتقديرى واحترامى لشخصكم الكريم ادام الله عليكم نعمه وفضله