نجوم المشاركات

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

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

فكرة البرنامج: عمل برنامج اكسيل يستوعب الكثير من البيانات باقل مساحه وبدون عناء فى استخدام الصيغ والمعادلات او الاكواد فى VBA وفى نفس الوقت يعرض العديد من التقارير . وهذا النموذج من البرنامج مجرد فكره ويمكن اعداد برامج شبيه له كما يناسب احتياجك . لاتنسونا بصالح دعاؤكم تحميل وشرح البرنامج http://excelfinancial1.blogspot.com.eg/2016/04/dashbord-sales.html تحميل ملف التطبيق sales.rar

السلام عليكم الاستعلام في وضع التصميم: ومهم جدا لنجاح هذه العملية ان يكون الاستعلام 1. بفرز مواد المجموعات ، ثم 2. بفرز الترقيم التلقائي مثلا ، وعمل الترقيم تقوم به الوحدة النمطية RowCounter : . والنتيجة: . ولتحديث الجدول Items ، يجب ان يكون لدينا الاستعلام اعلاه ، ثم يقوم الاستعلام qry_2_Update بتحديث الجدول على اساسه وهذه هي الوحدة النمطية: Option Compare Database Option Explicit Public Function RowCounter( _ ByVal strKey As String, _ ByVal booReset As Boolean, _ Optional ByVal strGroupKey As String) _ As Long ' Builds consecutive RowIDs in select, append or create query ' with the possibility of automatic reset. ' Optionally a grouping key can be passed to reset the row count ' for every group key. ' ' Usage (typical select query): ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter(CStr([ID]),False) <> RowCounter("",True)); ' ' Usage (with group key): ' SELECT RowCounter(CStr([ID]),False,CStr([GroupID])) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter(CStr([ID]),False) <> RowCounter("",True)); ' ' The Where statement resets the counter when the query is run ' and is needed for browsing a select query. ' ' Usage (typical append query, manual reset): ' 1. Reset counter manually: ' Call RowCounter(vbNullString, False) ' 2. Run query: ' INSERT INTO tblTemp ( RowID ) ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable; ' ' Usage (typical append query, automatic reset): ' INSERT INTO tblTemp ( RowID ) ' SELECT RowCounter(CStr([ID]),False) AS RowID, * ' FROM tblSomeTable ' WHERE (RowCounter("",True)=0); ' ' 2002-04-13. Cactus Data ApS. CPH ' 2002-09-09. Str() sometimes fails. Replaced with CStr(). ' 2005-10-21. Str(col.Count + 1) reduced to col.Count + 1. ' 2008-02-27. Optional group parameter added. ' 2010-08-04. Corrected that group key missed first row in group. Static col As New Collection Static strGroup As String On Error GoTo Err_RowCounter If booReset = True Then Set col = Nothing ElseIf strGroup <> strGroupKey Then Set col = Nothing strGroup = strGroupKey col.Add 1, strKey Else col.Add col.Count + 1, strKey End If RowCounter = col(strKey) Exit_RowCounter: Exit Function Err_RowCounter: Select Case Err Case 457 ' Key is present. Resume Next Case Else ' Some other error. Resume Exit_RowCounter End Select End Function Public Function Reset_RowCounter() Call RowCounter(vbNullString, False) End Function Public Function Correct_Last_Sequence() Dim rst As DAO.Recordset Dim Last_Seq As Integer Set rst = CurrentDb.OpenRecordset("Select * From 1 Order By Auto_ID Desc") rst.MoveNext Last_Seq = rst!M rst.MovePrevious rst.Edit rst!M = Last_Seq + 1 rst.Update rst.Close: Set rst = Nothing End Function جعفر 361.Database1.mdb.zip

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

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

الحمد لله الذي بنعمته تتم الصالحات أخي الحبيب وائل شعبان لقد استغرق مني العمل أيام .. بالبحث في المنتديات المختلفة والمواقع المختلفة ، والإضافة والتعديل للوضول لأفضل نتيجة ممكنة في الملف المرفق ستجد 3 أكواد .. الكود الأول المسمى Delete_Blanks_Basmla يقوم بحذف الصفوف التي تحتوي على البسملة عدا البسملة في الفاتحة والصفوف الفارغة والصفوف التي تحتوي أسماء السور ثم يأتي الكود الثاني (وسيستغرق في التنفيذ حوالي 5 دقائق لكيلا تقلق .. حاولت أن أجعله ينفذ بشكل أسرع ولكن يبدو أن البيانات ضخمة وعمليات المعالجة تحتاج لوقت ، ولكن لا أعتقد أن هذا سيسبب مشكلة حيث سيتم التنفيذ لمرة واحدة فقط .. للحصول على النتائج المطلوبة بعدها يمكنك نسح النتائج ووضعها في ملفك أو في أي ورقة عمل أخرى حسبما تريد) والكود المسئول على عمليات المعالجة للبيانات للحصول على المطلوب يسمى Main_Proc ثم يأتي في النهاية كود خفيف يقوم بوضع أسماء السور مقابل كل آية من الآيات في العمود الثاني وهو الكود SuratNames .. لتنفيذ الكود يمكنك الضغط على Alt + F8 ثم اختيار اسم الإجراء الفرعي المطلوب تنفيذه .. يراعى ترتيب التنفيذ (الكود الأول فالثاني فالثالث .. للحصول على نتائج منضبطة بإذن الله) أسأل الله العظيم أن يغفر لنا بهذا العمل وأن يجعله في ميزان حسناتنا يوم القيامة وأخيراً إليك الملف المرفق فيه ما ذكرت ، ولا تنسونا من صالح دعائكم .. لكي يظهر الملف بالخط المستخدم ، يرجى تنصيب الخط في المرفقات (فك الضغط عن الملف ثم كليك يمين ثم Install) حمل الملف من هنا UthmanicHafs1 Ver09.rar

أخي الكريم أحمد حمل الملف من هنا أرجو أن يكون المطلوب إن شاء الله تقبل تحياتي

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

....................................waiting

بارك الله فيك و لك مقدّمًا و مؤخّرًا جزاك الله خير الجزاء و زادك من علمه و فضله

بوركت سؤال آخر لماذا نكتب قبل المعادلة rds او mrd وماذا تعني ؟

السلام عليكم الأخ الجليل ياسر خليل المعلم القدير ياسر خليل دائما ودوما نجد حيث نحتاج اليك عمل مبهر ... كما عهدناك دوما جزاك الله خيرا

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

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

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

حياك الله في الحقيقة ، انا استخدم هذه الوحدة النمطية في برامجي الاساسية ، فالترقيم التلقائي فيها بعدة طرق (الامثلة موجودة في الوحدة النمطية) جعفر

توكل على الله كلنا بالانتظار فى شغف

على أحر من الجمر......

أخي الحبيب محمد الريفي أبو أحمد السلام عليكم...ريادة في الأعمال الرائدة..أي في مقدمة المقدمة مبدعي الإكسيل .. جزاكم الله خيرا..تقبل تحياتي..والسلام عليكم.

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

....................................I 'm waiting

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

جزاكم الله خيرا تحياتى و مزيد من الروائع

يرجى صورة توضيحية للمشكلة للتوضيح اكثر هل جربتي الاصلاح بهذه الاداة؟؟ MicrosoftFixit50274.rar

هل تريد عدم تكرار البيانات عد الى الموديل ستجد الجملة : ( 1 + ) مكررة 6 مرات قم بمسحها Dim Sh_LFP As Worksheet Dim Sh_LTR As Worksheet Dim Sh_LHL As Worksheet Dim Sh_IPD As Worksheet Sub Copy1() Application.ScreenUpdating = False Dim R_LFP As Long, LastR_LFP As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LFP = Sheets("LFP") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "J").End(xlUp).Row LastR_LFP = Sh_LFP.Cells(Rows.Count, "J").End(xlUp).Row For R_LFP = 2 To LastR_LFP Sh_LFP.Range("J" & R_LFP).Resize(1, 10).Copy Sh_IPD.Range("J" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 If R_LFP = LastR_LFP Then Copy2 Next End Sub Sub Copy2() Dim R_LTR As Long, LastR_LTR As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LTR = Sheets("LTR") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "T").End(xlUp).Row LastR_LTR = Sh_LTR.Cells(Rows.Count, "T").End(xlUp).Row For R_LTR = 2 To LastR_LTR Sh_LTR.Range("T" & R_LTR).Resize(1, 9).Copy Sh_IPD.Range("T" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 If R_LTR = LastR_LTR Then Copy3 Next End Sub Sub Copy3() Dim R_LHL As Long, LastR_LHL As Long Dim R_IPD As Long, LastR_IPD As Long Set Sh_LHL = Sheets("LHL") Set Sh_IPD = Sheets("IPD") LastR_IPD = Sh_IPD.Cells(Rows.Count, "AC").End(xlUp).Row LastR_LHL = Sh_LHL.Cells(Rows.Count, "AC").End(xlUp).Row For R_LHL = 2 To LastR_LHL Sh_LHL.Range("AC" & R_LHL).Resize(1, 9).Copy Sh_IPD.Range("AC" & LastR_IPD).PasteSpecial xlPasteValues LastR_IPD = LastR_IPD + 1 Next Application.ScreenUpdating = False End Sub

السلام عليكم هذا بالنسبة للترحيل فقط osamahreport2.rar

تفضل اخي الكريم لعله المطلوب اختر البحث بمعلومية الB or C Match.rar

أصيل أخوي ابوخليل ، وهذا نابع من طِيب اصلك رحم الله والديك على هذه الروح اخوي عمر جعفر

الحب في الله تعالى أوثق عرى الإيمان وهو منحة من الله لا يشترى بالمال . قال تعالى في بيان فضله على عباده المتحابين ( وَأَلَّفَ بَيْنَ قُلُوبِهِمْ لَوْ أَنفَقْتَ مَا فِي الأَرْضِ جَمِيعًا مَّا أَلَّفَتْ بَيْنَ قُلُوبِهِمْ وَلَكِنَّ اللهَ أَلَّفَ بَيْنَهُمْ إِنَّهُ عَزِيزٌ حَكِيمٌ ) . و قد جعل الله الحب في الله سببا للنجاة من النار و دخول الجنة ، ففي الحديث الصحيح المتفق عليه في السبعة الذين يظلهم الله تحت ظله ، منهم ( رجلان تحابا في الله ، اجتمعا عليه ، و تفرقا عليه ) المحبة في الله نعمة من الله ، فقد الأحبة في الله غربة ، والتواصل معهم أنس ومسرة ، هم للعين قرة ، فسلام على من دام في القلب ذكراهم ، وإن غابوا عن العين قلنا يا رب احفظهم وارعاهم . لا يوجد متسع للكلام ، أحبكم في الله جمعياً اخي في الله المبدع أ/ شوقي ربيع وثمرة التعاون المثمر بأذن الله بيننا ، نأتي من جديد في سلسة برامج ضاحي وشوقي الخدمية ، لتيسير ما امكن علي اخواننا , نفعنا الله واياكم بما علمنا ولا تنسونا بدعوة بصلاح الحال بظهر الغيب . كلمة مرور الأدمن admin VBA Password 6626 فورم تعديل / اضافة صلاحيات المستخدمين البرنامج بالمرفقات Multi User Form Permissions Management.rar

العضو الكريم fafa5000 اولا مرحبا بك في منتدى اوفيسنا ثانيا يرجى قراءة توجيهات المنتدى جيدا كمل يرجي تغيير اسم الظهور الخاص بك للغة العربية لسهولة التعامل تفضل كلمة المرور اسم المستخدم admin كلمة المرور admin VBA Password 6626

تفضل اظهار السعر تلقائيا بعد اختيار 11اسم المادة.rar

السلام عليكم مرحبا بكِ اختنا الكريمة ام روان في بيتك الثاني واسرتك الثانية اوفيسنا تحياتي

اخى الكريم تفضل الحل على حسب ما فهمت من طلبك شاهد المرفق واى تعديل انا تحت امرك وانصحك لو عايز تتعلم راجع الرابط التالى تقبل تحياتى Book1.zip

السلام عليكم نحن نحتاج (SQL Management Studio) للتاكد من اتصال (clinet) بالسيرفر وكذلك الى تغيير الرقم السري للدخول الى حساب المستخدمين برقم جديد --- فاذا تاكد الاتصال اثناء عمليه الربط بين ال (clinet) والسيرفر بعدم وجود (SQL Management Studio) وتمكنت من الدخول الى الحساب المستخدم بالرقم القديم فلا حاجه (SQL Management Studio) وسوف نجرب هذه الحاله باقرب وقت ونوافيكم بالنتيجه ان شاء الله بالتوفيق

أخي الكريم لم تحدد عدد الأرقام العشوائية المطلوبة التي توصلك للهدف المنشود ؟ عموماً جرب الملف التالي .. يمكنك سحب المعادلات إلى حيثما شئت وستجد أن مجموع الأرقام العشوائية المولدة في العمود الثاني يساوي 5000 كما طلبت في المرفق حمل الملف من هنا

غير فقط النطاق المسمى sRng الى النطاق (" Range("H3:NV202

السلام عليكم هذه اضافة بسيطة لكتابة ارقام الاآيات و عددها على اعتبار ان لدينا ورقة فيها اعداد الآيات مرتبة بالشكل 7 286 200 176 120 و هكذا حتى سورة الناس 6 Sub NbrAta() m = 0 Dim cl As Range For Each cl In Range("A1:A114") For x = 1 To cl.Value m = m + 1 Cells(m, 2) = x Cells(m, 3) = cl Next Next End Sub

أين التفاعل أم روان ..؟؟ ننتظر منك هدية للمنتدى بمناسبة انضمامك ... أول زنقة !!

ها هو الملف Book11.rar

أخي الكريم أحمد أعتقد أنك تحتاج لتنصيب NetFroamwork 3.5 >> لأن هذه المشكلة حدثت معي من فترة مع هذه المكتبة .. ما هو الويندوز الذي تستخدمه ؟

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

تفضل ... mathtest2.rar

مرحبا بك فى منتدانا

جزيت خير وبارك الله فيك.

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

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

السلام عليكم ورحمة الله وبركاته إخواني الكرام في منتدى أوفيسنا رغم قلة التفاعل في الموضوعات التي تقدم ، ولا أقصد بالتفاعل الردود العادية ، إنما أقصد المشاركة بالبحث والنقد والتفنيد والتفحيص والتدقيق والتمحيص والإضافة ...رغم قلة التفاعل أقدم كل يوم موضوع جديد لعل وعسى أن يأتي أناس من بعدنا ليستفيدوا مما نقدم ويكون المنتدى لهم نبراساً يستنيرون به في هذا المجال أقدم لكم موضوع حول إدراج أسماء الشهور بكل اللغات .. إليكم الكود التالي ، قم بوضع الكود في موديول عادي ... ثم نفذ الكود ولاحظ النتائج بنفسك Sub ListMonthsInAllLanguages() 'يقوم الكود بإدراج أسماء شهور السنة بكل اللغات '--------------------------------------------- Dim R As Long, C As Long Dim strDate As Date Dim S, bFind As Boolean Application.ScreenUpdating = False For R = 1 To 12 For C = 1 To 99 strDate = CDate("01/" & Format(R, "00") & "/2015") S = "[$-4" & Format(C, "00") & "]MMMM" Cells(R, C).NumberFormat = S Cells(R, C).Value = strDate Next C Next R Columns.AutoFit Application.ScreenUpdating = True End Sub أرجو أن ينال الملف والموضوع إعجابكم وتستفيدوا منه إن شاء الله حمل الملف من هنا تقبلوا تحياتي كان معكم أخوكم أبو البراء

الأستاذ / محمد عبارة السلام عليكم ورحمة الله وبركاته هذه الدالة مثل دالة الجمع التلقائي ولكن تستخدم عند التصفية أو الفرز لأنها لا تجمع القيم المخفية الناتجة من الفرز أو التصفية وبالنسبة لرقم 9 هذا رقم الجمع العادي وإذا اخترت بدل من 9 بـ 1مثلاً رقم 1 يعبر عن ايجاد المتوسط ورقم 2 ، 3 يستخدم لعد الخلايا ورقم 4 يستخدم لإيجاد أكبر قيمة ورقم 5 لأيجاد أصغر قيمة وهذا كله بعد التصفية أو الفرز .أرجو أن أكون وضحت بعض استخدامات هذه الدالة على حد علمي والله اعلم. وإليك الملف بعد استخدام هذه الدالة في الترقيم التلقائي. Book3.rar

السلام عليكم الاخ الكريم / الصّارم اعتقد ان التالي به طلبك تماماً ولكن عذرا للاطالة فالموضوع ليس موضوعي ولكنه للقدير العبقري الاستاذ القدير / جعفر طرباق .... جزاه الله خيرا بعنوان ((( كيف نجعل الملف ينتحر و يحدف نفسه من الجهاز تلقائيا ! )))) ولكني احببت ان انقله كما هو ليستفيد منه الجميع بكل طرقه واشكاله ============================================= الكود ادناه يفعل ذلك من داحل الملف نفسه و يمكن ربطه مثلا بالحدث Workbook_BeforeClose و مسح الملف تلقائيا و نهائيا و من دون اشعار المستخدم. SuicidalWorkbook.rar Option Explicit Private Const MSG_TITLE As String = "Deleting Current Workbook ..." Private Const MSG_TEXT As String = _ "You are about to permanently delete the current workbook located in :" Sub Kill_Myself() Dim lUserDecision As Long Dim sMsg As String On Error Resume Next sMsg = "Attention !" & vbNewLine & vbNewLine sMsg = sMsg & MSG_TEXT & vbNewLine sMsg = sMsg & "'" & ThisWorkbook.FullName & "'" & vbNewLine sMsg = sMsg & "from Disk!!" & vbNewLine & vbNewLine sMsg = sMsg & "Go ahead ?" & vbNewLine & vbNewLine Beep lUserDecision = _ MsgBox(sMsg, vbExclamation + vbYesNo, MSG_TITLE) With ThisWorkbook If lUserDecision = vbYes Then .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End If End With End Sub ====================================================== الكود التالي يحدف الملف بعد شهر واحد من اول استعماله تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Sub Workbook_Open() Dim lInitialDate As Long On Error Resume Next lInitialDate = Evaluate("InitialDate") If Err.Number = 13 Then Me.Names.Add "InitialDate", Date, False Me.Save End If If Date > Evaluate("InitialDate") + 30 Then Kill_Myself End Sub Private Sub Kill_Myself() .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود. ================================================================ الكود التالي يحدف الملف بعد 3 الستعمالات تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Kill_Myself End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود ========================================================= الكود التالي يحذف الملف بعد دقيقة واحدة من فتحه : (ضع الكود في ThisWorkbook Module) Option Explicit Private Const TIMEOUT As Long = 1 Private Sub Workbook_Open() Application.OnTime _ Now + TimeSerial(0, TIMEOUT, 0), Me.CodeName & ".Kill_Myself" End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub ===================================================== حذف الملف ولكن باشعار المستخدم بذلك !!!! للتمكن من اشعار المستخدم و في نفس الوقت منعه تماما من اجهاض عملية حذف الملف , اقترح الكود التالي حيث يتم اشعار المستخدم بعد حذف الملف و ليس قبل : (الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف) Option Explicit Private Const MAX_USES As Long = 3 Private Sub Workbook_Open() Dim lNumberOfUses As Long On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Call NotifyUser Call Kill_Myself End If End Sub Private Sub NotifyUser() Dim sVbsFile As String sVbsFile = Environ("Temp") & "\VBS_MSG.vbs" Open sVbsFile For Output As #1 Print #1, "Dim Wb" Print #1, "On Error Resume Next" Print #1, _ "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")" Print #1, _ "MSG= ""You have exceeded the Maximum Number of uses of this file."" & vbnewline & vbnewline" Print #1, _ "MSG= msg & ""The file has been permanently deleted from your Drive !""" Print #1, "Do" Print #1, "Loop until wb.name=""""" Print #1, "WScript.Echo MSG" Close #1 Call Shell("WScript.exe " & sVbsFile) End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub وارجو من الله ان يجعل فيها افادة ... وادعو للاستاذ القدير العملاق / جعفر ... جزاه الله خيرا جزاكم الله خيرا