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

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

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

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

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

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

واليوم أعرض على حضراتكم كيفية حماية  كل أوراق العمل فى الملف من التعديل مع ترك نطاق موحد  فى كل شيت أو أو نطاقات مختلفة من شيت لآخر 

وذلك خارج نطاق الحماية مع القابلية  للتعديل رغم الحماية المفروضة على الشيت .

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

Sub ProtectWbExpect2()
' Protect Workbook Expect Ranges
' by mokhtar 13/10/2015

Dim sh As Worksheet

Application.ScreenUpdating = False ' ايقاف تحديث الشاشة

On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى
  
  ' حلقة تكرارية للتعامل مع كل شيت فى الملف
  For Each sh In Worksheets
      
      ' اذا كانت محتويات الشيت محمية فان
      If sh.ProtectContents = True Then
          ' اجعل الشيت غير محمياً
          sh.Unprotect
          ' اسم الزر فى حالة عدم حماية الشيت
          Sheets("Sheet1").Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters.Text = "تفعيل حماية الأوراق"
          
          ' حلقة تكرارية لحذف جميع النطاقات المسموح يتعديلها فى الشيت
          For i = 1 To sh.Protection.AllowEditRanges.Count
            Debug.Print sh.Protection.AllowEditRanges(i)
            sh.Protection.AllowEditRanges(i).Delete
          Next   ' انهاء الحلقة التكرارية
          
          sh.Cells.Interior.Pattern = xlNone ' جعل خلايا الشيت بدون ألوان
           
           ' اضافة النطاقات المسموح بتعديلها أثناء حماية الشيت
          Sheets("Sheet1").Protection.AllowEditRanges.Add Title:="mokhtar1", Range:=Range("A1:B3")   ' اضافة النطاق فى الورقة الاولى
          Sheets("Sheet2").Protection.AllowEditRanges.Add Title:="mokhtar2", Range:=Range("A4:B6") ' اضافة النطاق فى الورقة الثانية
          Sheets("Sheet3").Protection.AllowEditRanges.Add Title:="mokhtar3", Range:=Range("A7:B9") ' اضافة النطاق فى الورقة الثالثة
          '  اذا كان النطاق المسموح بتعديله ثابتا فى كل  الأوراق
          ' sh.Protection.AllowEditRanges.Add Title:="mokhtar" & (i), Range:=Range("A1:B3")
      
      Else  ' أما اذا كانت محتويات الشيت غير محمية فان
           
           Sheets("Sheet1").Range("A1:B3").Interior.ColorIndex = 4   ' تمييز النطاق فى الورقة الاولى
           Sheets("Sheet2").Range("A4:B6").Interior.ColorIndex = 4  ' تمييز النطاق فى الورقة الثانية
           Sheets("Sheet3").Range("A7:B9").Interior.ColorIndex = 4  ' تمييز النطاق فى الورقة الثالثة
          ' sh.Range("A1:B3").Interior.ColorIndex = 4   ' تمييز النطاق اذا كان ثابثا فى كل  الاوراق
          
          ' اسم الزر فى حالة حماية الشيت
          Sheets("Sheet1").Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters.Text = "الغاء حماية الأوراق"
          ' اجعل الشيت  محميا
          sh.Protect
      End If          ' انهاء الشرط
  
  Next sh  ' انهاء الحلقة التكرارية

Application.ScreenUpdating = True  ' تشغيل تحديث الشاشة


End Sub

ملف للتجربة :

 

Protect All Sheets Expect Ranges .rar

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