محتاج مساعدة في شيت حوافز

[sief122]

عندي شيت حوافز للعاملين والعامل الزى يأخذ حوافزة بيتم كتابة اسمه في خلية التوقيع حتي يتم المعرفه انه قد صرف حوافزة

المطلوب : ان بعد كتابة اسم العامل في خلية التوقيع لايجوز التعديل او الحزف على نفس الخليه إلا بإدخال باسوورد وشكرا لحضرتكم وجازاكم الله خير ماتفعلون

شيت حوافز تجريبى.xlsx

[محمد هشام.]

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

جرب هدا 

Private Const Clé As String = "1234"   '   قم بتعديل الباسوورد بما يناسبك

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "J").End(xlUp).Row
    
    ActiveSheet.Unprotect Clé
    
    If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then
        Application.EnableEvents = False
        Dim cell As Range
        For Each cell In Target
            If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value)
        Next cell
        Application.EnableEvents = True
    End If
    
    ActiveSheet.Protect Clé, UserInterfaceOnly:=True
End Sub

'==================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim lastRow As Long, choose As String: Static OnRng As Range
    
    lastRow = Cells(Rows.Count, "J").End(xlUp).Row

    If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then
        If Not IsEmpty(Target.Value) Then
            If Target.Locked Then
                choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه")
                If choose = Clé Then
                    ActiveSheet.Unprotect Clé
                    If Not OnRng Is Nothing Then OnRng.Locked = True
                    Target.Locked = False
                    Set OnRng = Target
                    ActiveSheet.Protect Clé, UserInterfaceOnly:=True
                ElseIf choose <> "" Then
                    MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ"
                End If
            Else
                Set OnRng = Target
            End If
        Else
            ActiveSheet.Unprotect Clé
            Target.Locked = False
            Set OnRng = Nothing
            ActiveSheet.Protect Clé, UserInterfaceOnly:=True
        End If
    End If
End Sub

شيت حوافز تجريبى V2.xlsb

تم تعديل ديسمبر 13 بواسطه محمد هشام.

[sief122]

بارك الله فيك وجازاك الله خير مافعلت شكرا