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

كده Option Explicit Sub SaveShtsAsBook() Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1")) sh.Activate SheetName1 = ActiveSheet.Name SheetName2 = ActiveSheet.Name & "" & [c1] Cells.Copy Set NB = Workbooks.Add(xlWBATWorksheet) With NB With .ActiveSheet .Cells.PasteSpecial Paste:=xlAll .Cells.PasteSpecial Paste:=xlPasteValues .Name = SheetName1 [a1].Activate End With ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False .Close SaveChanges:=True End With .CutCopyMode = False Set NB = Nothing Next sh Sheets("SAles").Activate .ScreenUpdating = True .DisplayAlerts = True End With End Sub

لم ألتفت الى المعادلات أشكرك أخى ياسر على دقة المتابعة تم تعديل نوع لصق المنسوخ فى الكود Option Explicit Sub SaveShtsAsBook() Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1")) sh.Activate SheetName1 = ActiveSheet.Name SheetName2 = ActiveSheet.Name & "" & [c1] Cells.Copy Set NB = Workbooks.Add(xlWBATWorksheet) With NB With .ActiveSheet .Cells.PasteSpecial Paste:=xlPasteValues .Name = SheetName1 [a1].Activate End With ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False .Close SaveChanges:=True End With .CutCopyMode = False Set NB = Nothing Next sh Sheets("SAles").Activate .ScreenUpdating = True .DisplayAlerts = True End With End Sub

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

ههههههههههههههههى لو كنت أفضل واحدة لطبقتها كلها فيها ثغرات للدخول الى الملف

الأخ أبا حنين أعتقد أنه أثناء تجربتك للملف قد حدث خطأ ما فى ملف الاكسل قد يكون أن الملف النصى لم يتم انشاؤه أو أنك غيرت اسمه أو فى الداتا التى به والله أعلم على العموم بص على مسار الملف النصى واحذفه وجرب مع نسخة جديدة من الملف أو جرب تغيير المسار كما ذكر أستاذنا العزيز ياسر وهتلاقيها تظبط

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

وعليكم السلام أستاذ وائل استبدل السطر التالى فى كود المرفق ThisWorkbook.Sheets(Array("SAles", "Stk")).Copy Before:=NB.Sheets(1) بالسطر التالى : ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) تحياتى

أخى محمد انظر الرابط http://www.officena.net/ib/topic/64284-من-يريد-حماية-متميزة-لبرنامجه-يتفضل/ لأخينا ياسر العربى وده كود منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد ' Private Sub Workbook_Open() ' Dim MyPath As String ' Dim MyFlName As String ' ' MyPath = "Z:\SHARED GENERAL" ' MyFlName = "TEST-1.xls" ' If ThisWorkbook.Path <> MyPath Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' If ThisWorkbook.Name <> MyFlName Then ' Application.DisplayAlerts = False ' ThisWorkbook.Close ' End If ' End Sub ' Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) ' Dim lReply As Long ' ' If SaveAsUI = True Then ' lReply = MsgBox("عفواً لايمكنك حفظ هذا الملف بإسم جديد .. هل تريد حفظ الملف بإسمه الحالي ؟", vbQuestion + vbOKCancel) ' Cancel = (lReply = vbCancel) ' If Cancel = False Then Me.Save ' Cancel = True ' End If ' End Sub عدل فى الكود اسم و مسار الملف كما تشاء فاذا كان اسم الملف ومسار الملف غير المثبت فى الكود لن يفتح الملف

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

عايزين ولو حتى كل ساعة معلومة جميلة وخفيفة زى كده

أستاذ سليم كود رائع بارك الله فيك وجزاك خيرا

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

السلام عليكم أخى الأسيوطى جرب الملف التالى فيه نحفظ الورقة الاولى والثانية + ورقة من الاوراق التالية لهما فى ملف مستقل باسم حسب الخلية C1 فى هذه الورقه يتم تجميع الملفات الناتجة داخل مجلد يتم انشاؤه حسب اسم الملف والتاريخ الموجود في الخليه A1 من الصفحه الاولي لا تنسونا من صالح الدعاء ولو بظهر الغيب تحياتى Save Sheets As Books by mokhtar.rar

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

أستاذى الفاضل ياسر السطر ده يستدعى صندوق Style ومنه نختار الفورمات خط ولون ومحاذاة وحماية ........... Application.Dialogs(xlDialogApplyStyle).Show أو السطر ده : Application.Dialogs(xlDialogDefineStyle).Show الأخ ابو احمد تجميع الاوامر بالشكل الذى تريده لا يمكن حتى الان لانه من أساسيات الاوفيس لكن بامكانك عمل زر لكل قائمة تحياتى

تفضل ,ولى الامر .rar

الاخ الفاضل جرب التالى من قائمة data اختر edit link وتأكد من أن الخيار automatic نشط ومن الصندوق الحوارى اضغط startup prompt من الصندوق الجديد حدد الخيار 3 ثم ok ثم close احفظ الملف واقفله ثم أعد الفتح وشوف

الاخ أبو احمد ممكن يتعمل انتظر أحد الاخوة للرد للأسف أعمل على اكسل 2010 مش xp ولا 2003 لو عندك 2007 أو أعلى أخبرنى حيث لكل صندوق حوارى أمر استدعاء خاص تحياتى أمر التوسيط بالكود Sub MokhtarTest() Application.Dialogs(xlDialogAlignment).Show End Sub أمر نوع وحجم الخط Sub MokhtarTest2() Application.Dialogs(xlDialogFont).Show End Sub أو Sub MokhtarTest3() Application.Dialogs(xlDialogFontProperties).Show End Sub لاظهار صندوق الحماية الذى لا تريده Sub MokhtarTest4() Application.Dialogs(xlDialogCellProtection).Show End Sub ده متوفر فى 2007 فما فوق تحياتى

أستاذى العزيز الغالى ياسر خليل هذا بعض ما عندكم أستاذى الكبير لا حرمنا الله منك ولا من ابداعاتك المستمرة تحياتى وتقديرى الدائمين لشخصكم الكريم

السلام عليكم ورحمة الله وبركاته أساتذتى واخوتى اليوم أقدم لكم كودا منقولا بعد تعديله وترجمته لتحديد الفترة التجريبية لملف اكسل . فكرة الكود : عند فتح الملف يتم انشاء ملف نصى دون شعور المستخدم يتم تحرير تاريخ ووقت بداية فتح الملف فى الملف النصى بقورمات معين كما يظهر فى الكود بعد ذلك يقارن اكسل تاريخ اليوم مع التاريخ المحرر فى الملف النصى حتى تنتهى أيام الفترة التجريبية فاذا انتهت الفترة التجريبية يتم الآتى : 1 - اغلاق ملف الاكسل و عدم قدرتك على فتحه 2 - انشاء مجلد جديد تجد فيه : ملف نصى نشكرك فيه على تجربة المنتج وأوراق العمل فى الملف الأصلى تحفظ لك كل على حدة فى ملف مستقل الكود وعليه الشرح : Option Explicit Private Sub Workbook_Open() Dim StartTime#, CurrentTime# '---------------------------------------------------------- ' اعداد الفترة التجريبية كالتالى ' Integers 1, 2, 3,30 ,365 ...etc = number of days use ' 1/24 = 1hour , 1/48 = 30Mins , 1/144 = 10Mins use Const TrialPeriod# = 30 ' 30 days trial '---------------------------------------------------------- 'انشاء ملف مبهم المسار والاسم لتحديد بداية الفترة التجريبية Const ObscurePath = "C:\" Const ObscureFile = "Test File Log.Log" 'اذا كان الملف ذو المسار والاسم المحدد فارغا فان If Dir(ObscurePath & ObscureFile) = Empty Then ' بداية الوقت = تاريخ اليوم والوقت الحالى بالتنسيق الخاص StartTime = Format(Now, "#0.#########0") 'جواب الشرط : افتح الملف ذو المسار والاسم المحدد Open ObscurePath & ObscureFile For Output As #1 'تابع جواب الشرط : اكتب فى الملف بداية الوقت Print #1, StartTime Else ' فى حالة عدم تحقق الشرط فان 'افتح الملف ذو المسار والاسم للتحقق من وقت البداية Open ObscurePath & ObscureFile For Input As #1 Input #1, StartTime ' الوقت الحالى = تاريخ اليوم والوقت الحالى بالتنسيق الخاص CurrentTime = Format(Now, "#0.#########0") 'اذا كان الوقت الحالى أقل من بداية الوقت + الفترة التجريبية If CurrentTime < StartTime + TrialPeriod Then Close #1 ' غلق الملف المبهم قيد الاستعمال Exit Sub ' الخروج من الاجراء Else ' فى حالة عدم تحقق الشرط If [A1] <> "Expired" Then ' اذا كانت الخلية لا تساوى النص "Expired" فان ' رسالة للمستخدم بانتهاء الفترة التجريبية وعدم صلاحية الملف للاستعمال MsgBox "Sorry, your trial period has expired " & vbLf & _ "your data will now be extracted and saved for you..." & vbLf & "" & vbLf & _ "This workbook will then be made unusable." Close #1 ' غلق الملف المبهم قيد الاستعمال SaveShtsAsBook ' استدعاء كود حفظ البيانات للمستخدم [A1] = "Expired" ActiveWorkbook.Save ' حفظ الملف Application.Quit ' اغلاق اكسل نهائيا ElseIf [A1] = "Expired" Then ' اذا كانت الخلية تساوى النص "Expired" فان Close #1 ' غلق الملف المبهم قيد الاستعمال Application.Quit ' اغلاق اكسل نهائيا End If End If End If Close #1 End Sub Sub SaveShtsAsBook() ' كود حفظ بيانات المستخدم بحيث كل شيت يحفظ فى ملف منفصل Dim MyFilePath As String, Sheet As Worksheet, SheetName As String, N As Integer MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) With Application .ScreenUpdating = False ' ايقاف تحديث الشاشة .DisplayAlerts = False ' ايقاف التنبيهات On Error Resume Next ' فى حالة الخطأ تجاهله MkDir MyFilePath ' انشاء مجلد فارغ باسم الملف For N = 1 To Sheets.Count ' حلقة تكرارية بعدد أوراق الملف Sheets(N).Activate ' تنشيط الشيت SheetName = ActiveSheet.Name ' اعتبار المتغير = اسم الشيت Cells.Copy ' نسخ كامل الشيت Workbooks.Add (xlWBATWorksheet) ' انشاء ملف اكسل جديد With ActiveWorkbook ' مع الملف النشط With .ActiveSheet ' مع الشيت النشط .Paste ' لصق البيانات فيه .Name = SheetName ' تسمية الشيت النشط [A1].Select ' تنشيط الخلية End With ' حفظ الملف النشط فى المجلد باسم الشيت النشط .SaveAs FileName:=MyFilePath & "\" & SheetName & ".xls" ' غلق الملف النشط مع حفظ البيانات .Close SaveChanges:=True End With .CutCopyMode = False ' تفريغ الذاكرة العشوائية Next ' الشيت التالى End With ' انشاء ملف نصى به تعليمات هامة للمستخدم بداخل المجلد Open MyFilePath & "\Read Me.log" For Output As #1 ' كتابة الأسطر التالية فى الملف النصى Print #1, "Thank you for trying out this product." Print #1, "If it meets your Requirements, visit :" Print #1, "http://www.officena.com " Print #1, "to purchase the full version..." Print #1, "" Print #1, " --------- Regards -------------" Print #1, "Mokhtar Hussien officena team" Close #1 ' غلق الملف النصى End Sub الكود يوضع فى حدث Workbook بامكانك تعديل مسار الملف النصى وبامكانك تعديل الفترة التجريبية الى مدة زمنية محددة أو شهور أو سنوات كما يتضح فى التعليق المحرر فى الكود لتجربة الكود : اذهب الى الملف النصى ستجد رقما زى كده : 42298.7085185185 ده هو وقت تشغيل الملف نقص الفترة التجريبية المحددة فى الكود من الرقم الصحيح 42298. يعنى نخلية 42250 مثلا ونحفظ الملف النصى على كدة روح افتح الملف هتلاقى الملف يقلك لا شكرا على كده وهحفظلك بياناتك عشان متزعلش مرفق للتجربة : Trial Version Ended 30 days.rar

أخى الكريم الكود ككل مكون من عدة أكواد وليس كل الاكواد تربط بزر الكود Auto_Open و Auto_Close و kh_wVisible و ToggleCutCopyAndPaste و EnableMenuItem و CutCopyPasteDisabled لا تربط بأى أزرار فالكود مصمم بطريقة متشابكة يعنى كود يستدعى كود آخر فمثلا عند فتح الملف Auto_Open يشتغل لاخفاء القوائم لكى لا نستعمل القوائم فى القص والنسخ واللصق وعند غلقه Auto_Close يشتغل ليرجع الحال كما كان وكلاهما يستدعى ToggleCutCopyAndPaste لتعطيل عمليات النسخ والقص واللصق بلوحة المفاتيح ما يربط بزر كودان فقط EnableCutcopypaste و DisableCutcopypaste تحياتى

السلام عليكم الملف المفقود MSCAL.OCX بعد فك الضغط عن المرفق يوضع فى المسار التالى C:\Windows\System32 شغل الملف تحياتى MSCAL.zip

بارك الله فيك أستاذنا الفاضل العيدروس بعد تجربة الكود فى صورنه الأخيرة وجدت أنه يمكن التعديل فى البيانات اذا كان التاريخ لا يساوى تاريخ اليوم فمثلا اذا كان التاريخ 13 /10 /2015 وهو لا يساوى تاريخ اليوم 14/10/2015 فيمكن التعديل فى المبلغ بأن تقف فى الخلية التى تليها وحاول تعديلها ستجد أن الكود انتقل بك الى خلية المبلغ عندها عدّل المبلغ ستجد أنه تم تعديله والانتقال الى خلية المسلسل وبعد اذن حضرتك اسمح لى بهذا التعديل فمن شأنه عدم التعديل الا فى الخلايا التابعة لتاريخ اليوم فقط Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range For Each Rng In Range("TAREK").Areas If Not Application.Intersect(Target, Rng) Is Nothing Then If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات" Else Exit Sub End If End If Next End Sub تحياتى للجميع

السلام عليكم ورحمة الله تعالى وبركاته كل عام وحضراتكم بخير بمناسبة العام الهجرى الجديد لقد تناولنا فى موضوعى السابق حماية للشيت ما عدا نطاق محدد أو 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 والسلام عليكم ورحمة الله وبركاته

أخى الحبيب زيزو البسكرى أستاذى الفاضل محمد حسن أستاذى الفاضل ياسر خليل أستاذى الفاضل سليم حاصبيا بارك الله فيكم وجزاكم خيرا على مشاركاتكم البناءة والتى تثرى الموضوع اليكم صورة أخرى للكود تمكن المستخدم من اختيار النطاق المراد التعديل عليه كما ذكر الأستاذ سليم 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 تقبلوا خالص الشكر والتقدير