الكتابة مرة واحدة في خلية الأكسل ثم حمايتها تلقائياً

[alaagold11]

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

الأخوة الأفاضل 
أرجو مساعدتي في معادلة أو كود بحيث أكتب مرة واحدة في خلية أو عدة خلايا في الإكسل ثم يتم حمايتها تلقائباً بعد الكتابة مباشرة , بحيث لا يمكن التعديل عليها أو حذفها ,, وبحيث يمكن فك الحماية في أي وقت أريد بعد ذلك

ولكم الشكر

تم تعديل أبريل 6, 2017 بواسطه alaagold11

[سليم حاصبيا]

جرب هذا الملف

بعد ان تحفظ الباسوورد يمكن ازالة الخلايا الصفراء

protect non empty data with Pass word.rar

[alaagold11]

جزاك الله خير أستاذ سليم

لكن أنا ما فهم الملف

ممكن أوضح لكم المطلوب بشكل أخر

عندي ملف إكسل يوجد به صف يتم التسجيل في هذا الصف من أكثر من شخص والمشكله التي تقابلني أن هناك بعض الأشخاص يقومون بتعديل بعض الخلايا في هذا الصف 

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

ولكم الشكر

تم تعديل أبريل 6, 2017 بواسطه alaagold11

[سليم حاصبيا]

37 دقائق مضت, alaagold11 said:

جزاك الله خير أستاذ سليم

لكن أنا ما فهم الملف

ممكن أوضح لكم المطلوب بشكل أخر

عندي ملف إكسل يوجد به صف يتم التسجيل في هذا الصف من أكثر من شخص والمشكله التي تقابلني أن هناك بعض الأشخاص يقومون بتعديل بعض الخلايا في هذا الصف 

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

ولكم الشكر

ما هو النطاق الذي تريد ان تتم حمايته (من الخلية كذا الى الخاية كذا)أوضح ذلك بلغة الاكسل؟

او ارفع الملف او جزء منه اذا كان كبيراً

[alaagold11]

انا فهمت شيت الإكسل الذي أرسلته 

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

ولكن كيف أطبقة علي الشيت الذي أعمل به ؟

نظاق الخلايا من A1: إلي آخر الصف A

[سليم حاصبيا]

تم التعديل على الماكرو ليتناسب مع الوضع (كلمة السر pass) بشرط احتواء الخلية AA1  على الرقم 1 (غير مرئي)

الكود يعمل فقط في العامود A

لفك الحماية امسح الخلية AA1 و لاعادتها ارجع قيمتها الى 1

 

protect first column.rar

تم تعديل أبريل 6, 2017 بواسطه سليم حاصبيا

[alaagold11]

جزاك الله خير أستاذ سليم

 

كيف انقل الكود إلي الشيت الخاص بي ؟

تم تعديل أبريل 8, 2017 بواسطه alaagold11

[twaiti]

مشكور يا استاذ سليم  على مجهودك 

ارجوا التوضيح كيف يمكننا تفعيل الطريقة حيث قيمت بتحميل المثال الذي طرحته ولم اعرف كيف تم  الامر 

 

[twaiti]

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim My_String As String
My_String = ""
If Not Intersect(Target, Range("A:A")) Is Nothing Then
m = Target.Count
c = [AA1]
k = tt
If IsEmpty(k) Then GoTo 1
If m * c >= 1 Then
     Application.EnableEvents = False
     my_pass = Application.InputBox(" لا يمكن التعديل في هذه الخلايا.... الا بحالات خاصة تتطلب كلمة مرور", "password")
      If my_pass <> "pass" Then
      If Not (IsArray(k)) Then
       My_String = k
        Else
        For x = LBound(k, 1) To UBound(k, 1)
           My_String = My_String & k(x, 1) & ","
        Next
        My_String = Left(My_String, Len(My_String) - 1)
        End If
      MsgBox "اسف كلمة المرور غير صحيحة" & Chr(10) & " سيتم اعادة الخلايا الى قيمتها الاصلية:  " & Chr(10) & My_String, _
      vbMsgBoxRtlReading + vbInformation + vbMsgBoxRight, "ســليم حاصــبيّا يبلغك :"
      
      Application.Undo
      GoTo 1
      End If
       End If
    End If
1:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
tt = Selection.Value
End Sub

 

هدا هو الكود 

[alaagold11]

جزاك الله خير

سؤال آخر

كيف أجعل الباسورد التي أكتبها تكون علي هيئة نجوم ؟؟

[alkaser]

جزاكم الله خير على المعلومات القيمة

[alaagold11]

في ١٤‏/٤‏/٢٠١٧ at 20:21, twaiti said:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim My_String As String
My_String = ""
If Not Intersect(Target, Range("A:A")) Is Nothing Then
m = Target.Count
c = [AA1]
k = tt
If IsEmpty(k) Then GoTo 1
If m * c >= 1 Then
     Application.EnableEvents = False
     my_pass = Application.InputBox(" لا يمكن التعديل في هذه الخلايا.... الا بحالات خاصة تتطلب كلمة مرور", "password")
      If my_pass <> "pass" Then
      If Not (IsArray(k)) Then
       My_String = k
        Else
        For x = LBound(k, 1) To UBound(k, 1)
           My_String = My_String & k(x, 1) & ","
        Next
        My_String = Left(My_String, Len(My_String) - 1)
        End If
      MsgBox "اسف كلمة المرور غير صحيحة" & Chr(10) & " سيتم اعادة الخلايا الى قيمتها الاصلية:  " & Chr(10) & My_String, _
      vbMsgBoxRtlReading + vbInformation + vbMsgBoxRight, "ســليم حاصــبيّا يبلغك :"
      
      Application.Undo
      GoTo 1
      End If
       End If
    End If
1:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
tt = Selection.Value
End Sub

 

هدا هو الكود 

كيف يمكن تعديل النطاق ليكون مثلا من الخلايا من B5:B10 حتى D5:D10

[Ali Mohamed Ali]

تفضل اخى الكريم نفس ملف استاذنا الكريم سليم وتم تعديل المطلوب

 

protect first column.xlsm