محمد حسن المحمد

السلام عليكم ورحمة الله وبركاته الأكواد في حدث المصنف WorkBook Option Explicit Private Sub Workbook_Open() 'Test To Ensure Access Is Allowed (For 2002 Onward) If Application.Version > 9 Then Dim VisualBasicProject As Object On Error Resume Next Set VisualBasicProject = ActiveWorkbook.VBProject If Not Err.Number = 0 Then MsgBox "Your Current Security Settings Do Not Allow The Code In This Workbook " & vbNewLine & _ " To Work As Designed And You Will Get Some Error Messages." & vbNewLine & vbNewLine & _ "To Allow The Code To Function Correctly And Without Errors You Need" & vbNewLine & _ " To Change Your Security Setting As Follows:" & vbNewLine & vbNewLine & _ " 1. Select Tools - Macro - Security." & vbNewLine & _ " 2. Click The 'Trusted Sources' Tab" & vbNewLine & _ " 3. Place A Checkmark Next To 'Trust Access To Visual Basic Project.'" & vbNewLine & _ " 4. Save - Then Close And Re-open The Workbook", vbCritical End If End If 'Disable The Esc Key And Start Timer Application.EnableCancelKey = xlDisabled Run "StartTimer" End Sub 'All Subs And Event Procedures Should Have Run "DisableTimer" At The Head 'Of The Code And Run "StartTimer" At The End As Per The Examples Below. Private Sub Workbook_SheetCalculate(ByVal Sh As Object) Run "DisableTimer" Run "StartTimer" End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Run "DisableTimer" Run "StartTimer" End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Run "DisableTimer" Run "StartTimer" End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Run "DisableTimer" Run "StartTimer" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Run "DisableTimer" End Sub أما الموديول: Option Explicit Public IdleTime As Date Private Sub DeleteAllVBA() 'NOTE: The Following Procedures Run Every 5 Seconds, So We Want Execution Time 'To Be As Short A Time As Possible So That They Doesn't Interfere Unduly With Normal 'Workbook Operation, So Delete All Comments, Indenting, And Blank Lines In These 'Three Procedures When Finished. '------------------------------------------------------------------------------------ With ThisWorkbook If Sheet1.[A1] = "123" And .BuiltinDocumentProperties("Comments") = "123" Then 'In This Case Both Passwords Are Entered Correctly, So 'The Timer And The Rest Of This Procedure Are Redundant Run "DisableTimer" Exit Sub Else If .VBProject.Protection = 0 Then 'Unlocked Run "DisableTimer" 'Use Late Binding So No GUID Reference Is Needed Dim Component As Object 'Delete All VBA For Each Component In .VBProject.VBComponents With Component.CodeModule .DeleteLines 1, .CountOfLines End With Next Component 'Save And Close To 'Fix' The Changes .Save MsgBox "Sorry! An Incorrect Password Was Entered - All VBA Code Deleted - Re-enter Password To Check...)" Workbooks.Open (.FullName) '< Open 2nd Instance Of Saved Book .Close '< Close The 1st Instance Else 'Restart The Timer If The Project's Locked Run "StartTimer" End If End If End With Exit Sub End Sub Private Sub StartTimer() 'This Procedure Interferes With Work In The VBE If Accidentally Set Running, 'So We Disable It So The Developer Can Work There Uninterrupted... If Sheet1.[A1] = "123" And ThisWorkbook.BuiltinDocumentProperties("Comments") = "123" Then Exit Sub '<< Set Your Own Idle Time Below >> IdleTime = Now + TimeValue("00:00:05") Application.OnTime IdleTime, "DeleteAllVBA" End Sub Private Sub DisableTimer() On Error Resume Next Application.OnTime EarliestTime:=IdleTime, Procedure:="DeleteAllVBA", Schedule:=False End Sub قمت بنسخها ثم بعد إرفاقها جربت الملف وفتحه بكلمة السر ...كل ما ترونه بأعينكم أصبح في خبر كان كل هذه الكمية الهائلة من الأكواد والشروط أصبحت أثراً بعد عين ...بل لم يعد لها أثر ...ماهذا حتى الأثر زال ...عفوك يارب ...أين جثته ..رميمه ...تبخر...زال ...سبحان الذي أبدع العقول أما من سيكتشف ويسبر أغوارها فهم المختصون أمثالكم أيها الكرام والسلام عليكم.

الصحابي الجليل عمير بن الحمام(رضي الله عنه): في غزوة بدر كان الرسول (صلى الله عليه وآله وسلم) ينادي في المؤمنين ويحمس اصحابه قائلا: "قوموا إلى جنة عرضها السماوات والأرض". فلما سمع هذه الجملة الصحابي عمير بن الحمام رضي الله عنه قال متعجباً {عرضها السماوات والأرض} .. فأجابه رسول الله صلى الله عليه وآله سلم قائلا: {نعم} تلقى عمير رضي الله عنه تلقى الإجابة بسعادة غامرة وحماس منقطع النظير قائلا "بخ بخ" فقال رسول الله صلى الله عليه وسلم ما يحملك على قول بخ بخ هل عندك شك في هذا. فأسرع عمير يقول : لا والله يارسول الله ما قلتها إلا رجاءً أن أكون من أهلها. فقال رسول الله صلى الله عليه وسلم {فإنك من أهلها} في هذه اللحظة علم عمير أنه من أهل الجنة والذي يفصل بينه وبين الجنة الموت فقط لم يعد يستطيع أن يعيش لحظة على ظهر هذه الأرض وكان يمسك بيده بعض التمرا ليتقوى بها على القتال فنظر في هذه التمرات وفكر وللحظة تخيل الفرق بين هذه التمرات وثمار الجنة وطيور الجنة وشراب الجنة وحوض الرسول عليه الصلاة والسلام في الجنة فألقى بالتمرات على الأرض وقال {لإن أنا حييت حتى آكل تمراتي هذه إنها لحياة طويلة } وألقى بنفسه وسط الجموع الكافرة واستشهد رضي الله عنه.

اعذروني إخوتي ..أنفقت رصيد إعجاباتي ..حقكم أن يتم الإعجاب بمشاركاتكم القيمة..عذرا لا بخلا والسلام عليكم.

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

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

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

موعظـــــــــــــــــــــــــــــــــــــــــة أعطى أب لإبنه يوماً كيساً مليئاً بالمسامير وقال له: ( يا بني كلما اهنت شخص أو ضربت شخص أو جرحت شخص اذهب إلى سور الحديقة واطرق فيه مسماراً ) لم يفهم ذلك الولد لماذا طلب والده منه ذلك ولكنه امتثل لأمر والده وأصبح كلما يظلم أحداً أو يصرخ بوجه أحد أو يجرح أحداً يطرق مسماراً في ذلك السور ومع مرور الأيام أصبح الولد أكثر تحكماً في نفسه وانخفض عدد المسامير التي يطرقها كل يوم في السور إلى أن وصل اليوم الذي لم يطرق فيه ذلك الولد أي مسمار في السور فطار الولد من شدة الفرح وذهب إلى والده واخبره بذلك قال له والده: ( أحسنت يا بني أنت الآن شخص تتحكم في نفسك وفي أعصابك ولكن مهمتك لم تنته بعد ) استغرب الولد وقال: وماذا افعل بعد ذلك يا أبي ؟؟؟ قال الأب: ( كل يوم يمضي ولا تزعج أو تجرح أو تظلم فيه أحداً انزع مسماراً من ذلك السور مضت الأيام واستمر الولد في نزع المسامير في كل يوم لا يؤذي فيه أحداً إلى أن وصل اليوم الذي نزع فيه الولد آخر مسمار في ذلك السور فطار الولد من الفرح وذهب إلى والده ليخبره بذلك وعندما أخبره أخذ الأب ابنه إلى السور وقال أحسنت يا بني فأنت لم تصبح شخص متحكم في أعصابك فقط ولكنك أصبحت شخص طيب ولا تؤذي أحداً ولكن انظر إلى الثقوب في السور التي خلفتها تلك المسامير ……… لقد استطعت يا بني أن تنزع المسامير التي طرقتها ولكنك لا تستطيع محو تلك الثقوب التي تركتها المسامير !!! وكذلك هم البشر يا بني عندما تجرح أحدهم فأنت تطرق مسماراً في قلبه قد تستطيع أن تعتذر وتنزع ذلك المسمار ولكنك لن تنزع أثره وسيبقى ذكرى مؤلمة في حياة ذلك الشخص . لذلك يا بني لا تجرح الآخرين أو تؤذيهم بكلماتك فإنك لن تستطيع محو ذلك الجرح إلى الأبد ..

السلام عليكم إن صح عملي بنصيحتك يكون الكود على الشكل التالي: "والله أعلم" Sub SortByLEN() Application.ScreenUpdating = False With Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row) .FormulaR1C1 = "=LEN(RC[-1])" Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row), Order1:=xlDescending, Header:=xlNo .ClearContents End With Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله وبركاته أخي الحبيب أبو البراء وهذا كود آخر بحثت عنه وأضمه إلى باقتكم العطرة لكنني أود مراجعة آخر نقطة وقفت عنها لأنني لم أدركها ولم أستطع تطبيقها ... Sub kTest() Dim Rng As Range Application.ScreenUpdating = 0 Columns(1).Insert: Rows(1).Insert [a1] = "temp": [b1] = "texts" Set Rng = Range("a1", Range("b" & Rows.Count).End(xlUp)) With Rng .Offset(1).Resize(.Rows.Count - 1, 1).Formula = "=len(b2)" .Sort .Cells(2, 1), xlDescending, Header:=xlNo .Columns(1).Delete .Rows(1).Delete End With Application.ScreenUpdating = 1 End Sub

بارك الله بإخوتي الكرام الذين شاركونا هذا الموضوع ...الحمد لله ...الخير بأمة محمد إلى يوم القيامة... والسلام عليكم.

السلام عليكم أخي الحبيب أبو البراء ...جزاكم الله خيراً..عمل مميز

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

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

أحب ذلك بشكل أكيد ولكن عذري أن دوامي قارب على الانتهاء ...فأنا شغوف للتعلم منكم لأن به بركة وإن شاء الله الألزهايمر ما يضيعهم من ذاكرتي العجوز.

Sub SortByLEN() With Range("B1:B10") .FormulaR1C1 = "=LEN(RC[-1])" Range("A1:B10").Sort Key1:=Range("B1:B10"), Order1:=xlDescending, Header:=xlNo .ClearContents End With End Sub السلام عليكم ورحمة الله وبركاته ..هذا ما توصلت إليه أخيراً ...وقد عمل بشكل صحيح والسلام عليكم أتعبتكم معي...سامحوني.

للأسف لم يتم الفرز بهذه الطريقة Sub SortByLEN() With Range("A1:B10") .FormulaR1C1 = "=LEN(RC[-1])" .Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo .ClearContents End With End Sub

المشكلة في هذا السطر Range("A1:B10").Sort Key1:=Range("B1:B10"), Order1:=xlDescending, Header:=xlNo Sub SortByLEN() With Range("A1:B10") .FormulaR1C1 = "=LEN(RC[-1])" .Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo .ClearContents End With End Sub يرجى المساعدة بتصحيحه..جزاكم الله خيراً.

السلام عليكم أخي الحبيب أبو البراء تأخرت عليك لا تؤاخذني.. Sub SortByLEN() Range("B1:B10").FormulaR1C1 = "=LEN(RC[-1])" Range("A1:B10").Sort Key1:=Range("B1:B10"), Order1:=xlDescending, Header:=xlNo Range("B1:B10").ClearContents End Sub بارك الله بكم وبعلمكم ونفع به وجعله ذخراً لكم يوم القيامة ..آمين.

السلام عليكم أخي الحبيب أبو حمزة...ربنا يبارك لكم بحمزة ومن معه ...آمين درر سنية تتحفنا بها لتجعل يومنا عامراً بالتفاؤل ...جزاكم الله خيراً وأحسن إليكم...والسلام عليكم.

السلام عليكم ...تم التعديل ..جزاكم الله خيراً

السلام عليكم ورحمة الله وبركاته أخي الحبيب أبو البراء...أرجو أن يكون حلاً مناسباً بعد جهد جهيد...العلم في الصغر كالنقش في الحجر ..أما في الكبر فهو كوخز الأبر.. Sub SortByLEN() Range("B1").Select Range("B1").FormulaR1C1 = "=LEN(RC[-1])" Selection.AutoFill Destination:=Range("B1:B10") Range("A1:B10").Sort Key1:=Range("B1:B10"), Order1:=xlDescending, Header:=xlNo Range("B1:B10").ClearContents End Sub فرز حسب الأحرف تنازلياً.rar

السلام عليكم إن شاء الله تعالى بعد صلاة الجمعة

السلام عليكم طبقت ما ذكرت لي بموديول عن طريق تسجيل ماكرو أرجو أن ينال إعجابكم فرز حسب الأحرف تنازلياً.rar