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

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

أخى مهند السلام عليكم برجاء تغيير اسم الظهور لديك الى اللغة العربية لسهولة التواصل الشرح : If Not Application.Intersect(Target, Range("B7:B106,F7:F106")) Is Nothing Then If Target.Offset(, 1).Value < CVDate(Date) Then اذا تم تحديد أى خلية فى النطاقين B7: B106 و F7: F106 وكانت قيمة الخلية اللى جنب الخلية المحددة أقل من تاريخ اليوم فإن ........... يعنى مثلا لو كانت الخلية المحددة هى B7 بنشرط شرط وهو أن الخلية اللى جنبها وهى C7 لو التاريخ فيها أقل من تاريخ اليوم فتحدث الحماية واذا لم يتحقق الشرط فان الاكسل يتراجع عن التعديل بالجملة Application.undo طالما أن التاريخ فى C7 أقل من تاريخ اليوم و التعديل لا يكون الا بكلمة السر 123 هتسألنى ازاى أحدد الخلية اللى جنب خلية أخرى : A1 مثلا الخلية التى جنبها B1 ازاى نكتب B1 من غير ما نجيب سيرتها فى الكود : Range("A1").OFFSET(0,1) الجملة دى = B1 , ومعناها ازاحة بمقدار عمود واحد وبدون تغير فى عدد الصفوف للزيادة ابحث عن OFFSET

السلام عليكم اخوانى ورحمة الله وبركاته اليوم أقدم لكم كودا تستطيع من خلاله حماية الشيت ( بكلمة سر أو بدون ) مع ترك نطاق محدد مسموح للمستخدم بتعديله الطريقة التى أعتمد عليها AllowEditRanges والتى تسمح لمستخدمى اكسل التعديل فى نطاقات محددة رغم وجود حماية على الشيت لاحظ أيضا أنه يمكن عمل رقم سرى خاص بالنطاق المسموح بالتعديل عليه بخلاف الرقم السرى الخاص بحماية الشيت ان وجد . الكود وعليه الشرح وبعض الملاحظات : Sub ProtectSheetExceptRange() ' Protect ActiveSheet , but allow user edit Range("A1:A4,B1:D1") ' By Mokhtar 11/10/2015 On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى ' تحديد اسم الزر المشغل للكود فى حالة حماية الشيت النشط With ActiveSheet.Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters If .Text = "Protect ActiveSheet Except" Then .Text = "UnProtect ActiveSheet " ' حذف النطاق الاول المسموح بالتعديل فيه فى الشيت ActiveSheet.Protection.AllowEditRanges(1).Delete ' تحديد اسم و مدى النطاق المراد التعديل فيه أثناء حماية الشيت ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=Range("A1:A4,B1:D1") ' فى حالة الرغبة فى حماية النطاق المراد التعديل عليه برقم سرى بخلاف الرقم السرى الخاص بحماية الشيت ' ActiveSheet.Protection.AllowEditRanges.Add Title:="Protected Range", Range:=Range("A1:A4,B1:D1"), 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 ActiveSheet Except" End If End With End Sub تفضلوا المرفق وأتمنى أن تستفيدوا به فى أكوادكم وبرامجكم . تحياتى Protect Sheet Expect Range .rar

السلام عليكم ورحمة الله أستاذنا الغالى طريقة الموضوع تعجبنى فهى تجعل الطالب يبحث عن المعلومة والاستاذ يقيم و اسمح لى أستاذى بأن أشارك بهذه الطريقة : ضع الكود الكود التالى فى ملف الأستاذ سليم اللى هو 5 ميجا Option Explicit Sub ExcelDiet() Dim j As Long Dim k As Long Dim LastRow As Long Dim LastCol As Long Dim ColFormula As Range Dim RowFormula As Range Dim ColValue As Range Dim RowValue As Range Dim Shp As Shape Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each ws In Worksheets With ws 'Find the last used cell with a formula and value 'Search by Columns and Rows On Error Resume Next Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 'Determine the last column If ColFormula Is Nothing Then LastCol = 0 Else LastCol = ColFormula.Column End If If Not ColValue Is Nothing Then LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column) End If 'Determine the last row If RowFormula Is Nothing Then LastRow = 0 Else LastRow = RowFormula.Row End If If Not RowValue Is Nothing Then LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row) End If 'Determine if any shapes are beyond the last row and last column For Each Shp In .Shapes j = 0 k = 0 On Error Resume Next j = Shp.TopLeftCell.Row k = Shp.TopLeftCell.Column On Error GoTo 0 If j > 0 And k > 0 Then Do Until .Cells(j, k).Top > Shp.Top + Shp.Height j = j + 1 Loop If j > LastRow Then LastRow = j End If Do Until .Cells(j, k).Left > Shp.Left + Shp.Width k = k + 1 Loop If k > LastCol Then LastCol = k End If End If Next .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete End With Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub احفظ الملف بصيغة xlsb شوف حجمه ستجد أنه نزل للنصف تقريبا ثم افتح الملف وشغل الكود السابق ثم احفظ الملف واقفله شوف حجم الملف ستجد أنه 32 كيلو بايت اللى حصل هنا أن اكسل أعاد حساب النطاقات الغير مستخدمه فى الملف وحذفها تحياتى

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

السلام عليكم ورحمة الله وبركاته الأستاذ طارق ليك الحق تقول up up بس ما فكرتش ليه لحد دلوقتى مفيش ردود ؟! المهم جرب الكود ده ومتنساش ان حماية الملفات قاصرة وأى ناشئ اكسل يدوب لسه بيعرف اكسل يقدر يفقع لك الملف الكود يوضع فى حدث الورقة من خلال هذا الكود تستطيع تعديل البيانات فى النطاقين ("B7:B106,F7:F106") اذا كان التاريخ فى النطاقين ("C7:C106,G7:G106") أكبر أو يساوى تاريخ اليوم واذا كان التاريخ فى النطاقين ("C7:C106,G7:G106") أقل من تاريخ اليوم لن تستطيع التعديل بالا بادخال الرقم السرى الموجود بالكود 123 Private Sub Worksheet_Change(ByVal Target As Range) ' Protect Range from change After specific Date ' By Mokhtar 8/10/2015 Dim pwd As String: pwd = 123 If Not Application.Intersect(Target, Range("B7:B106,F7:F106")) Is Nothing Then If Target.Offset(, 1).Value < CVDate(Date) Then If Application.InputBox("برجاءإدخال كلمةالمرور لتعديل البيانات", "تصريح تعديل بيانات", "***") <> pwd Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات" Else Exit Sub End If End If End If End Sub تحياتى عدم السماح للمستخدم بتعديل ائ بيانات 2 .rar

السلام عليكم جزاك الله خيرا أستاذى العزيز جعفر أستاذى العزيز ياسر قمت بتجربة الكود واشتغل معى اوفيس 2010 Cut Copy PseudoEvent by jaafar .rar

أخى العزيز خالد الشاعر جزاكم الله خيرا وتقبل الله منا و منكم أخى العزيز عبدالعزيز جزاكم الله خيرا وتقبل الله منا و منكم أخى وأستاذى الغالى ياسر جزاكم الله خيرا وتقبل الله منا و منكم يا معلمى العزيز

أخى وأستاذى الغالى جعفر زادك الله بسطةً فى العلم و الرزق أشكرك على هذا التوضيح أخى وأستاذى الغالى ياسر زادك الله بسطةً فى العلم و الرزق أشكرك على هذا الدعاء

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

أخى الغالى جعفر أنت عبقرى بمعنى الكلمة لكن الكود لم يصبح أكثر مرونة فهو الأن قاصر على الفلاش فقط المرونة المنشودة هى أن يستطيع المستخدم أن يختار بين اما أن تفرغ المعادلات الخاطئة أو تلون أو تعطى قيمة معينة أو اشعال الوميض فيها فيمكن اضافة input box يدخل فيه المستخدم رقما 1 أو 2 أو 3 أو 4 1 تعمل التفريغ 2 تلون 3 تعطى قيمة 4 تشعل الوميض أعتقد أن هذا يعطى مرونة أكثر أرجو أن تكون الفكرة واضحة

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

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

أساتذتى واخوانى الأعزاء السلام عليكم ورحمة الله وبركاته اليوم أقدم لكم كودا تستطيع من خلاله أن تعرض على المستخدم رسالة Message box ثم تختفى الـ Message box بعد تعامل المستخدم مع أزرار ها فاذا لم يتدخل تختفى الـ Message box تلقائيا بعد مدة زمنية محددة الكود وعليه شرح بسيط : Sub MokhtarTest() Dim Title As String Dim Delay As Byte Dim iType As Integer Dim Msg As String Dim MyObject As Object ' عنوان الرساله Title = " منتدى أوفيسنا" Delay = 2 ' مدة عرض الرساله بالثانية iType = 0 ' نوع الرسالة يساوى عدد مما يأتى ' من 128 الى 134' من 64 الى 70 ' من 32 الى 38 ' من 16 الى 22 ' من صفر الى 6 Msg = Space(10) & "مرحبا" & vbLf & vbLf & " تاريخ اليوم " & vbLf & vbLf & Date ' حجم ونص الرسالة Set MyObject = CreateObject("WScript.Shell") MyObject.Popup Msg, Delay, Title, iType Set MyObject = Nothing ' تفريغ الذاكرة End Sub تفضلوا المرفق والسلام عليكم displays a timed Message box then hide without click buttons .rar

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

أساتذتى الأفاضل والزملاء الأعزاء أنا الآن بصدد عمل MsgBox من النوع standrd لها أزرار نعم لكن تختفي بتدخل أو بدون تدخل المستخدم بعد فترة زمنية فلا يزال الموضوع مستمرا فبعد ساعات سأنتهى من تجربة الكود ان شاء الله

أخى الكريم هناك مواقع متخصصة فى تحويل pdf الى اكسل او ورد أما التحويل عن طريق الأكواد فيلزمه برنامج Adobe reader Acrobat معتمد من الشركة والله أعلى وأعلم

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

السلام عليكم ورحمة الله اليكم الكود المميز التالى أعتقد أنه للأستاذ عبدالله باقشير صالح للاصدارات الحديثة من 2007 فما فوق يمنع النسخ والقص واللصق من خلال الماوس والكيبورد معا ومن خلاله تستطيع تعطيل و تفعيل النسخ والقص واللصق بالرقم السرى 123 ( يمكن تعديله ) Public xx As Integer Public x As Integer Sub Auto_Open() Application.ScreenUpdating = False Application.DisplayAlerts = False kh_wVisible True Application.ScreenUpdating = False ActiveWindow.DisplayWorkbookTabs = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" Call ToggleCutCopyAndPaste(False) Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic End Sub Sub Auto_Close() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i As Integer kh_wVisible False ThisWorkbook.Close Not CBool(ThisWorkbook.Saved) Application.DisplayFormulaBar = True Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)" Call ToggleCutCopyAndPaste(True) Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub kh_wVisible(ibol As Boolean) Application.ScreenUpdating = False Application.DisplayAlerts = False Dim nBook As String nBook = ThisWorkbook.Name With Windows(nBook) If .Visible = Not ibol Then .Visible = ibol End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub EnableCutcopypaste() Application.ScreenUpdating = False Application.DisplayAlerts = False xx: Dim x x = InputBox("لتفعيل النسخ يتطلب" & Chr(13) & "الرجاء ادخال كلمة المرور", "كلمة مرور") If IsNull(x) Or x = "" Then GoTo xx If x = "123" Then Call ToggleCutCopyAndPaste(True) Else MsgBox "كلمة مرور غير صحيحة" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub DisableCutcopypaste() Application.ScreenUpdating = False Application.DisplayAlerts = False Call ToggleCutCopyAndPaste(False) Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub ToggleCutCopyAndPaste(Allow As Boolean) Application.ScreenUpdating = False Application.DisplayAlerts = False 'Activate/deactivate cut, copy, paste and pastespecial menu items Call EnableMenuItem(21, Allow) ' cut Call EnableMenuItem(19, Allow) ' copy Call EnableMenuItem(22, Allow) ' paste Call EnableMenuItem(755, Allow) ' pastespecial 'Activate/deactivate drag and drop ability Application.CellDragAndDrop = Allow 'Activate/deactivate cut, copy, paste and pastespecial shortcut keys With Application Select Case Allow Case Is = False .OnKey "^c", "CutCopyPasteDisabled" .OnKey "^v", "CutCopyPasteDisabled" .OnKey "^x", "CutCopyPasteDisabled" .OnKey "+{DEL}", "CutCopyPasteDisabled" .OnKey "^{INSERT}", "CutCopyPasteDisabled" Case Is = True .OnKey "^c" .OnKey "^v" .OnKey "^x" .OnKey "+{DEL}" .OnKey "^{INSERT}" End Select End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean) Application.ScreenUpdating = False Application.DisplayAlerts = False 'Activate/Deactivate specific menu item Dim cBar As CommandBar Dim cBarCtrl As CommandBarControl For Each cBar In Application.CommandBars If cBar.Name <> "Clipboard" Then Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True) If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub CutCopyPasteDisabled() Application.ScreenUpdating = False Application.DisplayAlerts = False 'Inform user that the functions have been disabled MsgBox "نأسف تم تعطيل النسخ والقص واللصق فى هذا الملف!" Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub المرفق Disable Enable Cut copy paste .rar

السلام عليكم أستاذى الفاضل جعفر بارك الله فيك وجزيت خيرا على هذه الاضافات القوية للموضوع ولى سؤال : هل هناك MsgBox بدون أى زر زى ok cancel Retry والكلام ده و تختفى هذه الـ MsgBox بدون تدخل المستخدم ؟ لو كانت الاجابة بنعم برجاء ارفاق كود للتجربة تحياتى

أخى الحبيب ياسر فتحى بارك الله فيك ، سلمت من كل شر ، يشرفنى مرورك وتشجيعك الدائم يا بش مهندس

السّلام عليكم و رحمة الله و بركاته أستاذى الفاضل عادل حنفى بارك الله فيك ، سلمت من كل شر ، شرفنى مرورك أستاذى الكريم أخى العزيز زيزو البسكرى بارك الله فيك دائما تشرفنى بمرورك العزيز أخى وأستاذى الغالى ياسر خليل أشكرك بحرارة على هذا التشجيع الدائم والمستمر وهذا ما تعلمته من المنتدى ومنك تحديداً أستاذى الفاضل

السلام عليكم ورحمة الله وبركاته وبعد ,,, أقدم لكم اخوتى الأفاضل كودا يقوم بفحص نطاق من الخلايا ويحدد فقط الخلايا التى تحوى معادلات ذات القيم الخاطئة ويميزها بالتلوين أو التعديل أو التفريغ أو بعمل فلاش لتلك الخلايا لك الخيار فى اختيار شكل التمييز المناسب الكود وعليه شرح بعض السطور : Option Explicit Private Declare Function sndPlaySound32 Lib "winmm.dll" _ Alias "sndPlaySoundA" (ByVal lpszSoundName _ As String, ByVal uFlags As Long) As Long Sub CheckRangeForError() ' by mokhtat 2/10/2015 ' Error values include #DIV/0!, #N/A, #NAME?, #NULL!, #NUM!, #REF!, and #VALUE!. Dim C As Range Dim i As Integer Dim PlaySound As Boolean ' تحديد نطاق الفحص Sheets("Sheet1").Range("A2:F20").Select ' تحديد الخلايا التى تتضمن أخطاء Selection.SpecialCells(xlCellTypeFormulas, 16).Select ' استدعاء صوت من أصوات الويندوز للتنبيه على انتهاء الفحص PlaySound = True If PlaySound Then Call sndPlaySound32("C:\windows\media\notify.wav", 1) ' حدد الصوت المفضل لك طبقاً للمسار المقابل End If ' رسالة الى المستخدم بسؤال عن الرغبة فى التمييز أم لا If MsgBox(" تم انتهاء الفحص , هل تريد تمييز الخلايا ؟ ", vbYesNo + vbQuestion) = vbNo Then Exit Sub ' فى حالة اختيار لا يتم الخروج من الاجراء Else ' فى حالة اختيار تعم يتم عمل تمييز للخلايا بالتفريغ أو بالتعديل أو التلوين أو الفلاش ' ------------------------------------------------------------ ' تمييز الخلايا التى بها اخطاء بالتعديل ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "معادلة خاطئة" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتفريغ ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتلوين ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Interior.ColorIndex = 3 ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالفلاش For Each C In Sheets("Sheet1").Range("A2:F20") If IsError(C.Value) Then C.Select With C For i = 1 To 2 ' عدد مرات الوميض Application.Wait (Now + TimeValue("0:00:01")) ' انتظار مؤقت لمدة ثانية .Interior.ColorIndex = 6 Application.Wait (Now + TimeValue("0:00:01")) .Interior.ColorIndex = 7 Next .Interior.ColorIndex = xlNone .Font.Color = -16777024 End With End If Next '------------------------------------------------------------ End If End Sub تفضلوا المرفق وتقبلوا تحياتى select all cells if contains Error value .rar

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

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