اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

حماية خلايا


الردود الموصى بها

استاذنا العزيز اشكرك جدا على ما تجود به وطلبي هو ان تشمل الحماية مديات لا تشابه ما تضمنته الورقة الاولى ( اي ان المديات المحميه ليست متشابهه في كافة الاوراق ) كأن تكون في (J5:l30,m5:o50) وهكذا ، هل يتطلب الموضوع مثالا جديدا ارفقه مع الامتنان

رابط هذا التعليق
شارك

السلام عليكم

الشكر واصل للاخ الحبيب عادل حفظه الله

ولاثراء الموضوع

اضفنا زر تشييك في الورقة AA

باسم "ok_off"

عن طريقه يتم التحكم في الحماية

يوضع الكود التالي في الوحدة النمطية ThisWorkbook

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If Worksheets("AA").Shapes("ok_off").ControlFormat.Value = xlOn Then

    Set MyTarget = Nothing


    If Sh.Name = "AA" Then Set MyTarget = Sh.Range("B2:B30,D2:G30")

    If Sh.Name = "BB" Then Set MyTarget = Sh.Range("D5:E10")

    If Sh.Name = "DD" Then Set MyTarget = Sh.Range("E4:E10")


    If Not MyTarget Is Nothing Then

        If Not Intersect(Target, MyTarget) Is Nothing Then Sh.Cells(Target.Row, 1).Select

    End If


    Set MyTarget = Nothing

End If

End Sub

شاهد المرفق

كود حماية خلايا.rar

رابط هذا التعليق
شارك

السلام عليكم

اخي ولد المجرب

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

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

ولا تنسي وضع الكود التالي في thisworkbook

Private Sub Workbook_Open()

Sheets("ورقة1").Range("v1000") = 1

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

 If Sheets("ورقة1").Range("V1000") = 1 Then

If Not Intersect(Target, ActiveSheet.Range("b2:b30,d2:g30")) Is Nothing Then Cells(Target.Row, 1).Select

End If

End Sub

جرب و اخبرني النتيجة

تحياتي

رابط هذا التعليق
شارك

استاذنا الكبير تحية طيبه في المشاركه رقم(6)اوضحت طلبي حول امكانية شمول الحمايه اي مدى في اية ورقه بلا تحديد والاجراءات التي تفضلتم بها كانت قد انجزت وعمل الكود بطريقته الرائعه ولكن بمدى محدد لكل الاوراق ثم جاد الاستاذ خبور بكود رائع لم استطع اتخاذ ما يلزم ليعمل لنسياني الطريقه التي بها يتم نقل زر التفعيل الى البرنامج الذي اعمل عليه.

اتمنى ان يكون هناك زران ( للتفعيل والغاءه )مع الامتنان.

رابط هذا التعليق
شارك

السلام عليكم

اخي بعد وضع الكود في الوده النمطية

يوضع الكود التالي في الوحدة النمطية ThisWorkbook

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

If Worksheets("AA").Shapes("ok_off").ControlFormat.Value = xlOn Then

    Set MyTarget = Nothing


    If Sh.Name = "AA" Then Set MyTarget = Sh.Range("B2:B30,D2:G30")

    If Sh.Name = "BB" Then Set MyTarget = Sh.Range("D5:E10")

    If Sh.Name = "DD" Then Set MyTarget = Sh.Range("E4:E10")


    If Not MyTarget Is Nothing Then

        If Not Intersect(Target, MyTarget) Is Nothing Then Sh.Cells(Target.Row, 1).Select

    End If


    Set MyTarget = Nothing

End If

End Sub

قم من خلاله بتغيير اساء اللاوراق التي تريدها والنطاقا ت التي تريد ها التي تريده لهذه الاورق

ام الزر قم بنسخه من الملف ولصقه في اي ورقة ترديها وغير اسم هذه الورقة في الكود

رابط هذا التعليق
شارك

السلام عليكم

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

احتمالات المشكلة قد تكون في التالي:

1- اسم الورقة التي فيها الزر غير صحيح

2- اسم الزر غير صحيج

3- اسماء الاوراق التي فيها الخلايا غير صحيحة

لا تياس سريعا اخي حاول ثم حاول ثم حاول ثم اعد تكرار المحاولة من جديد

وبعدها سياتي النجاح

ودمتم في حفظ الله

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information