مطلوب كود vba لا يسمح بتعديل ما يكتب فى الخلية

[ehabaf2]

السلام عليكم الاخوة الكرام

كل عام و حضراتكم بالف خير و سعادة 

مطلوب كود vba لا يسمح بتعديل ما يكتب فى أسطر محددة

يعني يقبل الكتابة داخل الاسطر المحددة و لكن بعد الكتابة لا يمكن بمسحها او تعديلها الا بعد فك حماية الملف

مرفق الملف للتوضيح و التعديل رقم حماية الملف 1

عدم التعديل فى اسطر محددة.xlsx

[علي بن علي]

يمكنك استخدام الكود التالي لمنع تعديل أو حذف الخلايا من A2:K2 إلا بعد فك حماية ورقة العمل:

هذا كمثال فقط وانت عدل على الكود على حسب الخلايا التي او النطاق الذي لديك

ضع الكود في حدث الورقه التي تريد تطبيق منع الكتابه على خلاياها بعد الادخال

الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim protectedRange As Range
    Set protectedRange = Range("A2:K2")
    If Not Intersect(Target, protectedRange) Is Nothing Then
        Application.EnableEvents = False
        Application.Undo
        MsgBox "لا يمكن تعديل هذه الخلية، يرجى فك حماية الورقة للقيام بذلك"
        Application.EnableEvents = True
    End If
End Sub

يتم تنفيذ هذا الكود عند تغيير قيمة في الورقة. إذا تم تغيير أي خلية في النطاق المحدد (A2:K2)، فسيتم التحقق مما إذا كانت الورقة محمية أم لا. إذا كانت المنطقة محمية، فسيتم إلغاء التغيير وإظهار رسالة تذكيرية تطلب فك حماية الورقة.

عندما تكون مستعدًا للسماح بتعديل الخلايا في هذا النطاق، يمكنك فك حماية الورقة باستخدام الأمر التالي:
ActiveSheet.Unprotect Password:="mypassword"

يجب استبدال "mypassword" بكلمة مرور الحماية الحالية التي تم استخدامها لحماية الورقة. بعد ذلك، يمكنك تعديل الخلايا في النطاق المحدد. بعد الانتهاء من التعديلات، يمكنك إعادة حماية الورقة باستخدام الأمر التالي:
ActiveSheet.Protect Password:="mypassword"

مرة أخرى، يجب استبدال "mypassword" بكلمة مرور الحماية التي تريد استخدامها.

اتمنى يكون المطلوب . 

[أبوأحـمـد]

جرب

عدم التعديل فى اسطر محددة.xlsm

[ehabaf2]

الاستاذ الفاضل على بن على شكرا لحضرتك بس الكود لا يسمح بالكتابة و لكن المطلوب انه يسمح بالكتابة اول مرة و لا يسمح بالتعديل بعد ذلك

اريد كتابة كود غلق الخلايا فى النطاق المحدد فى الشيت المرفق بحيث عندما اكتب فيه تغلق الخلية و لا يسمح بالتعديل الا بعد فك الحماية

الاستاذ الفاضل أبو احمد الف الف شكر لحضرتك الكود يعمل و هو المطلوب اكرر شكرى لحضرتك

لكن عند تحديد اكتر من خلية يعطى رسالة خطأ و الخليه عند الكتابة بها اكتر من مرة تسمح بالمسح 

[علي بن علي]

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

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

الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Set rng = Range("A2:K50")
    If Not Intersect(Target, rng) Is Nothing Then
        If Target.Value = "" Then
            Target.Locked = False
        Else
            Target.Locked = True
        End If
        rng.Locked = True
        rng.SpecialCells(xlCellTypeBlanks).Locked = False
        ActiveSheet.Protect Password:="password", UserInterfaceOnly:=True
    End If
End Sub

هذا الكود يعني أنه عند تغيير قيمة الخلية في النطاق المحدد (A2:K50)، يتم التحقق من حالة الخلية قبل تحديد حالة القفل عليها. إذا كانت الخلية فارغة، فسيتم إلغاء حالة القفل عنها، مما يسمح بالكتابة في الخلية. إذا تم إدخال قيمة في الخلية، فسيتم تحديد حالة القفل على الخلية، مما يعني أنه لن يتمكن أحد من تحرير أو تعديل الخلية.

يتم أيضًا تحديد حالة القفل على النطاق بأكمله، ولكن يتم إلغاء حالة القفل عن جميع الخلايا الفارغة في النطاق، مما يسمح بالكتابة في هذه الخلايا الفارغة. يتم حماية الورقة بكلمة مرور "password"، ولكن باستخدام الخيار UserInterfaceOnly:=True، يتم السماح للمستخدم بتغيير القيم في الخلايا، ولكن لن يتم السماح له بإزالة الحماية أو تغيير حالة القفل على الخلايا.

عند تشغيل الحماية، سيتم حماية النطاق المحدد بحيث لن يتمكن أحد من تحرير أو تعديل أي خلية في هذا النطاق، ما لم تكن  الخلية فارغة

حظ موفق

[أبوأحـمـد]

في 10‏/7‏/2023 at 18:46, ehabaf2 said:

عند تحديد اكتر من خلية يعطى رسالة خطأ و الخليه عند الكتابة بها اكتر من مرة تسمح بالمسح 

وعليكم السلام

جرب الآن 

Option Explicit

Public ii As String

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("C603:j611"), Target) Is Nothing And ii <> "" And ActiveSheet.ProtectContents = True Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 On Error Resume Next
If Not Intersect(Range("C603:j611"), Target) Is Nothing Then ii = Target.Value
End Sub

 

[ehabaf2]

السلام عليكم الاساتذة الافاضل

كود الاستاذ على بن على لا يعمل عند كتابة اي رقم يعطى رسالة خطأ

كود الاستاذ أبو أحمد يعمل جيدا و لكن يسمح بالتعديل بعد أكتب فى الخلية مرتين

 

هل ممكن تعديل الكود التالى باضافة نطاق محدد مثلا من A1 الى H00

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect "1"
Target.Locked = True
ActiveSheet.Protect "1"
End Sub

وشكر لجميع السادة الاساتذة الخبراء على ما يقدمونه من مساعدة

[أبوأحـمـد]

Option Explicit

Public ii As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("A1:c11"), Target) Is Nothing And ii = True And ActiveSheet.ProtectContents = True Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 On Error Resume Next
ii = False
If Not IsEmpty(Target) Then ii = True
End Sub

جرب هذا

[حسونة حسين]

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

جرب هذا التعديل اخي @ehabaf2

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim X As Range
    For Each X In Target
        '  600 هو اخر سطر لعمل الكود
        'L  هو العامود  column 12
        If (X.Row < 600 And X.Column < 12) Then
            If ActiveSheet.ProtectContents = True And X.Value <> "" Then X.Offset(0, 1).Select
        End If
    Next
End Sub

 

عدم التعديل فى اسطر محددة.xlsb

[ehabaf2]

استاذنا الفاضل أبو أحمد

الكود يسمح بالتعديل على الخلية المكتوبة لو كتبت فى الخلية اكتر من مرة 

مرفق ملف للتوضيح

غلق.xlsm

[ehabaf2]

الحمد لله الحمد لله الحمد لله

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

الف شكر حضرتك

و الف شكر لجميع الاساتذة الافاضل و جميع الاعضاء 

 

[حسونة حسين]

الحمد لله تم المطلوب اخى @ehabaf2

[ehabaf2]

استاذنا الفاضل  حسونة حسين

اعتزر اريد الكود يعمل على نطاق محدد و باقى الشيت يعمل عادى خارج نطاق الكود

مثلا الكود يعمل داخل نطاق من A100 الى C120 فقط وباقى الشيت يعمل عادى هل ده ممكن

[حسونة حسين]

تفضل اخي

عدل هذا السطر

If (X.Row < 600 And X.Column < 12) Then

الى

If (X.Row >= 100 and X.Row <= 120 And X.Column < 4) Then

 

[ehabaf2]

السلام عليكم استاذنا الفاضل حسونة حسين

الكود بعد التعديل يعمل و الحمد لله

الف الف شكر لحضرتك