حماية تلقائية للبيانات بكل أوراق العمل عدا نطاقات محددة قابلة للتعديل بكلمة سر

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

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

تناولت فى الفترة الماضية  مايأتى
حماية للشيت ما عدا نطاق محدد أو Protect Sheet Expect Range  على الرابط

http://www.officena.net/ib/topic/64169-حماية-للشيت-ما-عدا-نطاق-محدد-أو-protect-sheet-expect-range/

حماية كل أوراق العمل ما عدا نطاقات محددة أو Protect All Sheets Expect Ranges  على الرابط

http://www.officena.net/ib/topic/64193-حماية-كل-أوراق-العمل-ما-عدا-نطاقات-محددة-أو-protect-all-sheets-expect-ranges/

واليوم أقدم لكم  حماية تلقائية للبيانات بمجرد فتح الملف لكل أوراق العمل مع استثناء نطاقات محددة قابلة لتعديل البيانات بها  و بكلمة سر   

كلمة السر هى unloock  ( ممكن تغييرها من الكود ) وهذا بناء على طلب أخونا وائل الأسيوطى

الكود وعليه الشرح

Dim sh As Worksheet
Private Sub Workbook_Activate()
' Auto Protect Workbook Expect Ranges
' by mokhtar 25/10/2015

With Application
     .DisplayAlerts = False  '  تعطيل التنبيهات
     .ScreenUpdating = False '  تعطيل تحديث الشاشة

     For Each sh In Worksheets   ' لكل شيت فى الاوراراق
        If sh.ProtectContents = True Then   ' اذا كان الشيت محميا فان
           ' لا تفعل شيئا
           Else ' واذا لم يكن محميا
           sh.Protect  '  اجعل الشيت محميا
        End If '  انهاء الشرط
     Next sh ' الشيت التالى
     ActiveWorkbook.Save ' حفظ
    .DisplayAlerts = True ' اعادة تشغيل التنبيهات
    .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة
End With
End Sub

Private Sub Workbook_Open()

With Application
    .DisplayAlerts = False  '  تعطيل التنبيهات
    .ScreenUpdating = False '  تعطيل تحديث الشاشة

On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى
  ' حلقة تكرارية للتعامل مع كل شيت فى الملف
      For Each sh In Worksheets
      ' اذا كانت محتويات الشيت محمية فان
          If sh.ProtectContents = True Then
              ' اجعل الشيت غير محمياً
              sh.Unprotect
              ' حلقة تكرارية لحذف جميع النطاقات المسموح يتعديلها فى الشيت
              For i = 1 To sh.Protection.AllowEditRanges.Count
                  Debug.Print sh.Protection.AllowEditRanges(i)
                  sh.Protection.AllowEditRanges(i).Delete
              Next i  ' انهاء الحلقة التكرارية
              ' اضافة النطاقات المسموح بتعديلها أثناء حماية الشيت
              Sheets("Sheet1").Protection.AllowEditRanges.Add Title:="mokhtar1", Range:=Range("A18:G29"), Password:="unloock"   ' اضافة النطاق فى الورقة الاولى
              Sheets("Sheet2").Protection.AllowEditRanges.Add Title:="mokhtar2", Range:=Range("F6,H7,D8,F14,H14"), Password:="unloock" ' اضافة النطاق فى الورقة الثانية
              Sheets("Sheet3").Protection.AllowEditRanges.Add Title:="mokhtar3", Range:=Range("D2,F3,D6,B8,F11,B14,D14"), Password:="unloock" ' اضافة النطاق فى الورقة الثالثة
              Sheets("Sheet4").Protection.AllowEditRanges.Add Title:="mokhtar4", Range:=Range("F10:F23"), Password:="unloock" ' اضافة النطاق فى الورقة الرابعة
              Else
              sh.Protect
         End If          ' انهاء الشرط
      Next sh  ' انهاء الحلقة التكرارية
   .DisplayAlerts = True ' اعادة تشغيل التنبيهات
   .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة
End With
End Sub

المرفق للتجربة

تحياتى والسلام عليكم

Auto Protect Workbook Expect Ranges By Mokhtar.rar

[Yasser Fathi Albanna]

دائما رائع أخى الغالى / مختار

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

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

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

دائما رائع أخى الغالى / مختار

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

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

أخى الغالى ياسر فتحى

بارك الله فيك  و مشكور على مرورك والله  فى أيام  كثر فيها  (اخطف واجري  قبل ما صاحب الموضوع  يدري  ...  )

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

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

هل تعلم أستاذي القدير مختار حسين محمود أنّي من هُواة أعمالك .. جزاك الله خيرًا و زادها بميزان حسناتك .. متعة حقيقيّة بروائع أكوادك

                                                                                  فائق إحتراماتي

 

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

أخى الغالى زيزو

أشكرك عظيم الشكر على كلامك بحقى  ودعاءك الطيب

والحمد لله الذى وفقنى لتحقيق متعة شخص ما -  ولو أنت فقط -  بعلم نافع

تحياتى وتقديرى لكل أهل بسكرة  الجزائرية

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

أخي الحبيب مختار

بارك الله فيك

إنت عارف إني دايما بشوف وأجرب وأرجع أجرب لحد ما الاقي فيه مشكلة ولا كله تمام

جرب تغير الباسورد الموجود داخل الكود ..واحفظ الملف وافتحه وجرب تعدل في الشيت الأول ..مفيش مشكلة هتكتب كلمة السر وكله تمام

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

 

[وائل الاسيوطي]

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

اخي الاسيوطي سلمت من كل شر وجزاك الله خيرا علي اعمالك القيمه 

[وائل الاسيوطي]

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

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

أستاذى الكبير ياسر

للعلم أنه يتم انشاء النطاقات المحمية بباسورد + الباسورد نفسه أثناء عدم حماية الشيت ثم تتم حماية الشيت

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

لتغيير الباسورد : غيره فى الكود + فك حماية الشيت + Allow user to Edit Ranges  +  حذف للنطاق + أعد حماية الشيت + حفظ + غلق الملف واعادة فتحه

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

يعنى ضع الكود فى الملف الجديد واعمل حماية للشيتات قبل الحفظ   ثم أغلق الملف وأعد فتحه هتلاقيه شغال .