حماية للشيت ما عدا نطاق محدد أو Protect Sheet Expect Range

[مختار حسين محمود]

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

اليوم أقدم لكم كودا تستطيع من خلاله حماية الشيت ( بكلمة سر أو بدون ) مع ترك نطاق محدد مسموح للمستخدم بتعديله

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

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

الكود وعليه الشرح وبعض الملاحظات :

Sub ProtectSheetExceptRange()
' Protect ActiveSheet , but allow user edit Range("A1:A4,B1:D1")
' By Mokhtar 11/10/2015
    
  On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى
  
  ' تحديد اسم الزر المشغل للكود فى حالة حماية الشيت النشط
  With ActiveSheet.Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters
      If .Text = "Protect ActiveSheet Except" Then
         .Text = "UnProtect ActiveSheet "
           
         ' حذف النطاق الاول المسموح بالتعديل فيه فى الشيت
           ActiveSheet.Protection.AllowEditRanges(1).Delete
           
         ' تحديد اسم و مدى النطاق المراد التعديل فيه أثناء حماية الشيت
           ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=Range("A1:A4,B1:D1")
           
         ' فى حالة الرغبة فى حماية النطاق المراد التعديل عليه برقم سرى بخلاف الرقم السرى الخاص بحماية الشيت
         ' ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=Range("A1:A4,B1:D1"), Password:=123
           
         ' حماية الشيت  بدون كلمة سر
           ActiveSheet.Protect
         ' حماية الشيت بكلمة سر
         ' ActiveSheet.Protect Password:=123
           
         ' تعريف المستخدم بالنطاق المسموح بالتعديل فيه
           With ActiveSheet.Protection.AllowEditRanges.Item(1)
               MsgBox "ActiveSheet is Protecting" & vbNewLine & "Except Range : " & .Range.Address & vbNewLine & vbNewLine & "Regards ...Mokhtar "
           End With
            
           Else  ' اذا لم يكن هذا فان
                     
         '   فك حماية الشيت المحمى بدون كلمة سر
           ActiveSheet.Unprotect
         ' فى حالة فك حماية الشيت المحمى  بكلمة سر
         ' ActiveSheet.Unprotect Password:=123
         ' اسم الزر المشغل للكود فى حالة عدم حماية الشيت النشط
           .Text = "Protect ActiveSheet Except"
           
      End If
   End With
End Sub

 تفضلوا المرفق وأتمنى أن تستفيدوا به فى أكوادكم وبرامجكم .  تحياتى

Protect Sheet Expect Range .rar

[ابوحمزه المصرى]

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

[إبراهيم ابوليله]

اخى مختار

ايه الجمال والحلاوه دى

دائما ما تاتى بموضوع مفيد

تقبل تحياتى

[مختار حسين محمود]

أخى صلاح 

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

أخى ابراهيم

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

[عبد العزيز البسكري]

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

 ....ونِعْمَ الهدايا أستاذي القدير مختار حسين محمود .. و روعة المفاجآت

بارك الله فيك .. جزاك الله خيرًا وزادها بميزان حسناتك ..تشكر يا غالي

                                   خالص إحتراماتي

 

[محمد حسن المحمد]

السلام عليكم أخي العزيز مختار

جزاكم الله خيرا على ماقدمتم وتقدمون وجعله بموازين حسناتكم...تحرزون البركة أهل مصر بصعيده وكل مناطقه...فأنتم مثال للطيبة وحسن اﻷدب ودماثة الخلق..تتميزون به عن كثير من الشعوب ولا أقلل هنا من شأن أحد ولكن كلمة حق تقال...والله تعالى جعلنا شعوبا وقبائل لنتعارف

تقبل تحياتي.

[ياسر خليل أبو البراء]

أخي الغالي م ح م (مختار حسين محمود)

تميز بكل جديد كعادتك دائماً والأكثر روعة هو تقديم شرح للكود مما يسهل على الأعضاء التعديل فيه وفهم كيفية عمل الكود والاستفادة منه

بارك الله فيك وجزاك الله خير الجزاء

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

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

Unprotect Only Choosen Range.zip

[مختار حسين محمود]

أخى  الحبيب زيزو البسكرى

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

أستاذى الفاضل ياسر خليل

أستاذى الفاضل سليم حاصبيا

بارك الله فيكم  وجزاكم خيرا على مشاركاتكم البناءة والتى تثرى الموضوع

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

Sub ProtectSheetExceptChoosenRange()
' Protect Sheet Except Choosen Range
' By Mokhtar 12/10/2015
  Dim S As Range
  On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى
  
  ' تحديد اسم الزر المشغل للكود فى حالة حماية الشيت النشط
  With ActiveSheet.Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters
      If .Text = "Protect Sheet Except Choosen Range" Then
         .Text = "UnProtect ActiveSheet"
           
           ' حذف النطاق الاول المسموح بالتعديل فيه فى الشيت
           ActiveSheet.Protection.AllowEditRanges(1).Delete
           ' حذف أى بيانات وفورمات فى الشيت
           With Cells
               .ClearContents
               .ClearFormats
           End With
          '  InputBox لاختيار النطاق المراد حمايته يتم انشاء
          Set S = Application.InputBox("select a Range to UnProtect", Type:=8)
          ' تمييز النطاق الذى تم اختياره
          With S
            .Interior.ColorIndex = 38
            .Borders.LineStyle = xlContinuous
          End With
         ' تحديد اسم و مدى النطاق المراد التعديل فيه أثناء حماية الشيت
           ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=S
           
         ' فى حالة الرغبة فى حماية النطاق المراد التعديل عليه برقم سرى بخلاف الرقم السرى الخاص بحماية الشيت
         ' ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=S, Password:=123
           
         ' حماية الشيت  بدون كلمة سر
           ActiveSheet.Protect
         ' حماية الشيت بكلمة سر
         ' ActiveSheet.Protect Password:=123
           
         ' تعريف المستخدم بالنطاق الغير محمى
           With ActiveSheet.Protection.AllowEditRanges.Item(1)
               MsgBox "ActiveSheet is Protecting" & vbNewLine & "Except Range : " & .Range.Address & vbNewLine & vbNewLine & "Regards ...Mokhtar "
           End With
            
           Else  ' اذا لم يكن هذا فان
                     
         '   فك حماية الشيت المحمى بدون كلمة سر
           ActiveSheet.Unprotect
         ' فى حالة فك حماية الشيت المحمى  بكلمة سر
         ' ActiveSheet.Unprotect Password:=123
         ' اسم الزر المشغل للكود فى حالة عدم حماية الشيت النشط
           .Text = "Protect Sheet Except Choosen Range"
           
      End If
   End With
End Sub

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