اريد كود يمنع حذف شيت معين

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

الاخوه الافاضل

نفترض ان لدى شيت مكون من اربع ورقات

واريد كود منع حزف الورقه الاولى والثانيه

[الـعيدروس]

السلام عليكم

هذه الأكواد انسخها الى حدث ThisWorkbook

لنفترض أنا الورقتين المراد عدم حذفها اساميهم "ورقة1" , "ورقة2"

Private Sub Workbook_Open()

Dim S$

With ActiveSheet

S = .Name

If S = "ورقة1" Or S = "ورقة2" Then

   Alidroos_Control_F

    Else

   Alidroos_Control_T

End If

End With

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

If Sh.Name = "ورقة1" Or Sh.Name = "ورقة2" Then

  Alidroos_Control_F

Else

  Alidroos_Control_T

End If

End Sub

Private Sub Alidroos_Control_F()

If Not Application.CommandBars Is Nothing Then

  With Application.CommandBars

   .FindControl(ID:=847).Enabled = False

   .FindControl(ID:=848).Enabled = False

  End With

End If

End Sub

Private Sub Alidroos_Control_T()

If Not Application.CommandBars Is Nothing Then

  With Application.CommandBars

   .FindControl(ID:=847).Enabled = True

   .FindControl(ID:=848).Enabled = True

  End With

End If

End Sub

تم تعديل أكتوبر 22, 2012 بواسطه عباد

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا نصار حفظكم الله

جزاكم الله كل خير.

هل ممكن التعديل في الكود حتى يكون المنع من الحذف والنسخ غير ممكن من القوائم أيضاً (أقصد يمكن الحذف والنسخ من قائمة تحريرتحايلاً على الكود).

كما أرجو أضافة كود أستعادة الخاصيتين للعمل عند أقفال الملف (كون بعد أققال الملف نجد أنهما غير مفعلتين في كل مستندات الأكسيل).

أبو أنس

تم تعديل أكتوبر 23, 2012 بواسطه أبو أنس حاجب

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

الاخ عباد بارك الله فيك

ممكن ارفاق شيت كمثال

لاننى لم استطع تفعيل الكود

[الـعيدروس]

السلام عليكم

تفضل المرفق وبه ملاحظة اخونا الفاضل أبو انس

Canel_Delete_Sheet.rar

[الـعيدروس]

ولمعرفة الكثير حول أرقام ID لدالة FindControl

Public Sub Com_All()

Dim R&, Ro%, E%

On Error Resume Next

With Application

    .ScreenUpdating = False

    .EnableEvents = False

Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).ClearContents

Range("A1:C1") = Array("تسلسل الرقم", "ايدي الامر", "نوعه المسمى")

R = 2

For Ro = 1 To 12500

Cells(R, 1) = Application.CommandBars.FindControl(ID:=Ro).Type

Cells(R, 2) = Application.CommandBars.FindControl(ID:=Ro).ID '***

Cells(R, 3) = Application.CommandBars.FindControl(ID:=Ro).Caption

R = R + 1

Next

E = Range("A20000").End(xlUp).Row

With Range("C2:C" & E)

   .VerticalAlignment = xlRight

   .HorizontalAlignment = xlRight

End With

For I = E To 2 Step -1

If Range("A" & I).Value = "" Then Range("A" & I).EntireRow.Delete

Next

   .EnableEvents = True

   .ScreenUpdating = True

End With

End Sub

تم تعديل أكتوبر 23, 2012 بواسطه عباد

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

الاخ عباد مشكورا على الرد

ولكن لا اعرف من اين ياتى الخطأ

عندما اقف على الورقه ثم اقوم بعم حزف يتم فعلا حزف الورقه1

وكذلك مع الورقه2

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

تم تعديل أكتوبر 23, 2012 بواسطه دغيدى

[الجزيرة]

شكرا ابا نصار ، لمشاركتك

ولكن يمكن التحايل على الكود بادراج ورقة جديدة وعندها يمكن حذف ورقة1 أو ورقة2

[أبو حنــــين]

يمكن عمل الكود التالي لكنه لا يسمح أي بحذف ورقة او اضافة ورقة

Private Sub Workbook_Open()

ActiveWorkbook.Protect Password:="123", Structure:=True, Windows:=False

End Sub

[الـعيدروس]

السلام عليكم

الاخ الفاضل الجزيره

هذا الكود في حدث Thisworkbook

يمنع ادراج ورقة جديدة

بالامكان استخدامه

Private Sub Workbook_NewSheet(ByVal SH As Object)

    MsgBox "لقد تمت عملية إدراج الورقة بنجاح.    ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

    Application.DisplayAlerts = False

    MsgBox "ولكن، لا يمكنك إدراج أي ورقة جديدة بهذا البرنامج.    ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading

    ActiveSheet.Delete

    MsgBox "وقد تمت عملية حذف الورقة بنجاح أيضاً.    ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

    Application.DisplayAlerts = True

End Sub

[عبدالله باقشير]

السلام عليكم

اخي عباد ---------- حفظك الله

من تبويب اي ورقة

اذا تم تحديد اكثر من ورقة ومن ضمنهم احدى الورقتين او كلاهما

يتم الحذف.

ايضا

من القائمة

تحرير

حذف ورقة

يتم الحذف

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

السلام عليكم

الاخ الفاضل الجزيره

هذا الكود في حدث Thisworkbook

يمنع ادراج ورقة جديدة

بالامكان استخدامه

Private Sub Workbook_NewSheet(ByVal SH As Object)

MsgBox "لقد تمت عملية إدراج الورقة بنجاح. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

Application.DisplayAlerts = False

MsgBox "ولكن، لا يمكنك إدراج أي ورقة جديدة بهذا البرنامج. ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading

ActiveSheet.Delete

MsgBox "وقد تمت عملية حذف الورقة بنجاح أيضاً. ", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading

Application.DisplayAlerts = True

End Sub

الاخ عباد تحيه طيبه وبعد

كود رائع

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

تم تعديل أكتوبر 24, 2012 بواسطه إبراهيم ابوليله

[الـعيدروس]

الكود يلغي النقل او النسخ

ولاكن ملاحظة استاذي عبدالله باقشير بمحلها

عند تحديد اكثر من ورقة

انا بحاول اتوصل الى حل

ان شاء الله

[محمدعوض]

اريد مساعدت في تعديل على الكود .........

اريد ان اضيف شيت زيادي عليه  

هذا هو الكود ....

Private Sub Workbook_Open()
Dim S$
With ActiveSheet
S = .Name
If S = "SALES" Or S = "RETURN" Then
   Alidroos_Control_F
        Else
   Alidroos_Control_T
End If
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Alidroos_Control_T
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "SALES" Or Sh.Name = "RETURN" Then
  Alidroos_Control_F
Else
  Alidroos_Control_T
End If
End Sub
Private Sub Alidroos_Control_F()
If Not Application.CommandBars Is Nothing Then
  With Application.CommandBars
   .FindControl(ID:=847).Enabled = False
   .FindControl(ID:=848).Enabled = False
  End With
End If
End Sub
Private Sub Alidroos_Control_T()
If Not Application.CommandBars Is Nothing Then
  With Application.CommandBars
   .FindControl(ID:=847).Enabled = True
   .FindControl(ID:=848).Enabled = True
  End With
End If
End Sub

[محمدعوض]

كيفية التعديل لااضافة شيت اخرى في اكسيل وشكرا  ....