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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله هذا الموضوع من فترة كنت أبحث فيه وأتذكر أن هناك من طلب مثل هذا الطلب ، كما أنه يوجد موضوع بالمنتدى في الأيام الأخيرة لا أتذكره يخص إغلاق التطبيق وكيفية منع الإغلاق عن طريق زر الإغلاق الخاص بالتطبيق ، ووجدت زخم من الأكواد ، ومتاهات إلخ ... فقررت عمل موضوع لإنهاء الأمر والقضاء عليه بهدوء .. بأكواد بسيطة جداً بعيداً عن الزخم الغير مرغوب فيه والتعقيد الذي لا أحبذه في كثير من الأحيان ففي البساطة لو تعمقت في المسألة ، ستجد دائماً الحلول اليسيرة التي قد لا تخطر على بال الكثيرين سيكون محور العملية في كودين أحدهما يوضع في موديول .. ويكون بالشكل التالي Public CloseMode As Boolean Sub CloseMe() CloseMode = True ThisWorkbook.Save Application.Quit End Sub السطر الأول دا إعلان (بس مش في التليفزيون ولا إعلان على مواقع الانترنت ) دا إعلان في مشروع المصنف VBA Project ولا يخص الموديول فقط ، بل هو إعلان عاااااااااااااااااااااااااام أي أنه يمكن التعامل معه في أي موديول (سواء موديول عادي أو موديول ورقة عمل أو موديول المصنف أو موديول الفورم) المتغير اللي بيتم الإعلان عنه اسمه CloseMode ونوعه (يا إما ذكر يا إما أنثى) ..( True أو False) الإجراء المسمى CloseMe (والترجمة اقفلني .. والكلام ليس لي .. لأنك لو قفلتني مش هنزل الموضوع ده >> إنما المتحدث هنا هو الإكسيل .. فالإكسيل بيقولك اقفلني شكراً .. بس متقفلنيش من زر الإغلاق ..ابعد عن زر الإغلاق وغني له) أول سطر في الإجراء بيخلي المتغير العام قيمته True وتاني سطر بيحفظ المصنف والتالت بخرج من التطبيق وبس خلاص دي قفلة الكود End Sub تقريبا دي اختصار هند صبري (إند صب) دا الجزء الأول .. انتهينا منه *************************** شوية نجوم عشان الناس تصحصح تاني وتركز في الجزء التاني (كأننا في مسلسل مهند ونور) Private Sub Workbook_BeforeClose(Cancel As Boolean) If Not CloseMode Then Cancel = True MsgBox "Please Use The button To Close This File" End If End Sub الجزء ده بيوضع في حدث المصنف .. وكما ذكر أخونا إبراهيم أبو ليلة في سلسلة شروحاته إن الحدث دا بيتنفذ قبل الإغلاق .. يعني ببساطة لما أدوس للإكسيل على طرف (اللي هو زر الإغلاق) يتنفذ الأسطر الموجودة الأسطر عبارة عن جملة شرطية بتقول ايه : (نركز ونصحى عشان أنا هنام منكم أهو) لو المتغير العام CloseMode منفي .. يعني قيمته Fasle وممكن نكتب الشرط بالشكل ده If CloseMode = False Then واحد هيسأل طيب لو كانت قيمة المتغير True مش كدا ممكن نستخدم زر الإغلاق ؟؟؟ أقوله صحيح .. بس المتغير العام القيمة الافتراضية له False .. أول ما نفتح المصنف أي متغير بتكون قيمته الافتراضية 0 مثلاً لو كان متغير من النوع Long ، أو فراغ "" لو كان المتغير String ، أما القيمة الافتراضية للمتغير Boolean يا ناس يا حلوين هي القيمة False المهم نرجع للشرط .. فلو كانت قيمة المتغير CloseMode تساوي False ينفذ اللي جاي .. يا إما أروح أمشي أنا يا شيخ عبد الستار وطبعاً زي ما قلت القيمة الافتراضية False بالتالي بالتالي وأكيد هينفذ باقي الكود باقي الكود .. السطر Cancel = True معناها الغي عمل زر الإغلاق ، ومش بس كدا .. أنا مش هسيبك تضرب أخماس في أسداس وتقول نسخة الأوفيس خربت عندي .. لا أنا هظهر لك رسالة عشان تتأكد إن النسخة مخربتش الرسالة بتقول : روح يا ولدي استخدم الزر اللي ياسر خليل عمله في ورقة العمل ، عشان زر الإغلاق بتاع التطبيق ، سعادته ياسر بيه لعب في أساسه وعطله (أصلي من النوع المعطلاتي) وطبعاً زي ما اتعودنا من الأخ شعبولة إننا نقفل ، فالشرط اللي بدأناه كمان لازم يقفل بـ End IF .. زي بس خلاص بتاعة شعبولة ** نقطة أخيرة : واحد سامعه بيفكر (على فكرة هو متكلمش هو لسه بيفكر ..) دلوقتي لو عايز أقفل من زر الإغلاق مع وجود الكودين دووول أعمل ايه ؟؟ الإجابة : بسيطة جداً روح واعمل إجراء فرعي وخلي قيمة المتغير العام CloseMode تساوي True ( وبكدا تقدر تستخدم زر الإغلاق مرة أخرى) Sub EnableCloseButton() CloseMode = True End Sub ونفذ الإجراء الفرعي ده .. ضع مؤشر الماوس داخل الإجراء الفرعي وانقر Run أي تنفيذ الإجراء الفرعي ، أو F5 من لوحة المفاتيح ... تقدر دلوقتي تقفل من زر الإغلاق عادي لأنك جعلت قيمة المتغير العام CloseMode تساوي True وأقفل أنا كمان موضوعي بالقفلة المعروفة بالنسبة لي .. دمتم على طاعة الله ، ولا تنسونا من صالح دعائكم حمل الملف من هنا

جرب المرفق التالي عله يفي بالغرض 01 V1.rar

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

السلام عليكم ورحمة الله وبركاته. فيديو جديد من احد دورات تدريب المحاسبين على برنامج الاكسيل . وهو حالة عملية متقدمه باستخدام الدالة VLOOKUP , MATCH , IFERROR ... اتمنى ان تكون مفيده جدا لكم جميعا تقبلو خالص تحياتى واحترامى https://www.youtube.com/watch?v=G5QV4V3OOt0

استاذى واخى الحبيب حسام (الصقر) قبل كل شىء مليون مبروك على الترقية التى تستحقها بكل جداره انت اللى واحشنى جدا وكل الاعضاء والاساتذة الموجودين فى اوفيسنا المكان الذى احبه واكون فى كامل الراحه والسعاده عندما اطرح فية موضوعا او سؤلا او اكون احد المشاركين فى الاجابات اسال الله ان يبارك لنا فى هذا الصرح الذى يجمعنا والف شكر على كلامتك الكثيره فى حقى تقبل تحيات اخوك عودنا اوفيسنا ان نتعرف خيرة الناس مثل الاستاذ ياسر العربى بارك الله فيك استاذ . انا من محبى التدوين اكتر من تسجيل الفيديوهات ولكن كان هذا تسجيل لى ولم يكن غير مرتب لة بالنشر لولا ان هناك من طلبى من ذلك واحب ان اهدى اليك هذا الموضوع وهو نفس الفكره بنسبة 100% تقبل منى خالص التحية

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

السلام عليكم الاخ الحبيب ياسر خليل جرب المرفق ان شاء الله يعمل معك تفعيل الأختصارات في أوامر الفورم4.rar

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

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

السلام عليكم أخي الحبيب أبو البراء ...درس رائع خفيف الدم ...حلقات بحث مفيدة وهامة...نتنقل في جامعتنا من تعليم الفورم...إلى تعليم الvba..ثم جديد أستاذنا الحبيب ياسر أبو البراءDisable Application Close Button أو زر منع إغلاق التطبيق...جزاكم الله خيرا"... والسلام عليكم...

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

ماشاء الله عليك استاذنا ياسر خليل بارك الله فيك وفى علمك وجزاكم عنا خيرا

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

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

السلام عليكم اخى الكريم على حسب ما فهمت ... ضع المعادله التاليه فى الخليه F8 ثم قم بالسحب يساراً =SUMPRODUCT((F$4:F$7=1)*($D$4:$D$7))

جرب الكود بهذا الشكل Private Sub CommandButton1_Click() DataEntry End Sub Private Sub CommandButton2_Click() End End Sub Private Sub UserForm_Activate() TextBox2.SetFocus End Sub Sub DataEntry() Dim TotalRows As Long Dim sh As Worksheet Set sh = ورقة1 If TextBox2.Text = "" Then MsgBox ("الرجاء ادخال اسم المادة") Exit Sub ElseIf TextBox3.Text = "" Then MsgBox ("الرجاء ادخال الكمية") Exit Sub ElseIf TextBox8.Text = "" Then MsgBox ("الرجاء ادخال سعر المادة") Exit Sub End If With sh TotalRows = .Cells(31, "C").End(xlUp).Row If TotalRows < 15 Then TotalRows = 15 Else TotalRows = TotalRows End If .Cells(TotalRows + 1, 3) = Me.TextBox2.Value .Cells(TotalRows + 1, 4) = Me.TextBox3.Value .Cells(TotalRows + 1, 5) = Me.TextBox8.Value .Cells(TotalRows + 1, 6) = Me.TextBox9.Value End With Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox8.Value = "" Me.TextBox9.Value = "" Me.TextBox2.SetFocus End Sub

الطريقه الرابعه :- استخدام لغة البرمجه هى بنظرى من اهم الطرق واسهلها وهى تكون من خلال البرمجه فقط ولا يمكن تنفيذها من شاشة الخصائص فى مرحله التصميم شاهد الصوره التالية هتعرف ما هى الطريقه الكود هو بشكل مكبر عباره عن سطر واحد فقط ComboBox1.RowSource = "sheet1!a2:b" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row تعالو نفصص كل كلمة فى هذا السطر ونعرف ازاى نكتبه comboBox هو اسم الكمبوبوكس المراد تعبئته بالبيانات . تكتب من خلال جعل الكيبورد انجلش ثم نضغط على حرف ز بالعربى RowSource هى الخاصيه المسئوله عن تعبئة الكمبوبوكس بالبيانات = نكتب علامه = " نفتح قوس تنصيص " ويكتب من خلال شفت+حرف ط بالعربى Sheet1!a2 وهى اول خلية بالجدول المراد عرض بياناته فى الكمبوبوكس (ونلاحظ اننا كتبنا اسم الشيت متبوع بعلامة تعجب ! ثم اسم الخلية) : تعنى الى b اسم اخر عمود بالجدول " قفل قوس التنصيص طالما فتحنا قوس اذن لازم نقفله & علامة و أو بمعنى and Sheet1.Cells(Rows.Count, "a").End(xlUp).Row اخر خليه بها بيانات بالعمود A طيب عرفنا ازاى نكتب الكود فما هو وقت تنفيذ الكود السطر ده هيتم وضعه فى اى حدث ( والله دى بقى حضرتك اللى تحددها حسب برنامجك انت ولكن على سبيل المثال نضع هذا الكود فى حدث فتح الفورم شاهد الكود Private Sub UserForm_Initialize() ComboBox1.RowSource = "sheet1!a2:b" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row End Sub فعند فتح الفورم وتهيئته يتم تعبئة الكمبوبوكس بالبيانات ممكن نكتبه بشكل تانى لو حابب تعرف اكتر من طريقه شوف الكود وبعدين اشرحه لك Private Sub UserForm_Initialize() Lr = Sheet1.Cells(Rows.Count, "a").End(xlUp).Row ComboBox1.RowSource = "sheet1!a2:b" & Lr End Sub قمت بعمل متغير وسميته Lr وممكن تسميها انت بأى اسم كما تحب وقلت ان المتغير ده عباره عن اخر خلية بها بيانات بالعمود A وبالتالى كتبة المصدر بتاع البيانات كالتالى sheet1!a2:b" & Lr" تم الاستعاضه بـ Lr بدلا من السطره ده Sheet1.Cells(Rows.Count, "a").End(xlUp).Row ويمكن كتابة الكود بشكل اخر ( ملحوظه هذا التنوع بالكتابه هو فقط من حيث اسلوب كتابة الكود لكن المضمون واحد) Private Sub UserForm_Initialize() With ComboBox1 .RowSource = "sheet1!a2:b" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row End With End Sub الى هنا انتهى درس اليوم اعتقد انه بسيط وممتع يارب اكون وفقت بالشرح وتستفيدو منه عايز اشوف تجاربكم على الدرس على رابط الردود الخاص بالموضوع اتمنى لكم التوفيق وانتظرونا فى طريقه جديده قريبا بأذن الله

أخي الحبيب ياسر العربي بارك الله فيك وجزاك الله خيراً على الموضوع الرائع نسيت تذكر أن يقوم المستخدم بنسخ الملف dll إلى مسار الويندوز مجلد System32 طيب خد أبسط حاجة :: افتح برنامج الإكسيل Ctrl + O اختصار أمر Open لفتح الملفات حدد الملف الخاص بك والمسمى DiskSerial.xlsm ومن لوحة المفاتيح اضغط Shift مع الاستمرار بس خلاص الملف تم فتحه بدون اللجوء إلى معرفة سيريال الهارد ديسك

السلام عليكم ورحمة الله وبركاته . معلومه عالسريع الدالة ( EOMONTH ) تستخدم لمعرفة اخر يوم في الشهر وتستخدم كما موضح بالصورة منقول

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

بعد اذن اخي ابو البراء تفضل انا معملتش حاجه من عندي كله تغيير مسار بس Test0.rar

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

اخي الحبيب حسام انت تستحقها وان شاء الله سنري منك المزيد خالص تحياتي وتقديري

كود جميل اخي سليم سلمت يداك وهذه بطريقة اخري مع تغيير اسم الزر تحياتي كشف عام مرتبات.rar

السلام عليكم اخي الكريم تم عمل كود الترحيل حسب فهمي لطلبك شاهد المرفق واخبرني عن رايك facture.rar

السلام عليكم ورحمة الله وبركاته الدرس الحادي عشر 11-Worksheet&Workbook Events احداث الورك بوك والورك شيت وسوف نتناول فى هذه الدرس الاتى Worksheet_SelectionChange Worksheet_Activate Worksheet_Deactivate Worksheet_Change Worksheet_BeforeDoubleClick Worksheet_BeforeRightClick Workbook_Open Workbook_BeforeClose Workbook_BeforeSave Workbook_AfterSave Workbook_SheetActivate Workbook_SheetBeforeDoubleClick Workbook_SheetBeforeRightClick Workbook_NewSheet Workbook_SheetChange Workbook_SheetSelectionChange ............................................................................................. سوف نتناول هنا بعض الاكواد التى توضع فى حدث الورقه مع محاولة توضيح كيفية استخدامها كيفية اضافة الاكواد الخاصه بالحدث Worksheet يتم ذلك عن طريق الدخول الى محرر الاكواد ثم اختيار الشيت الذى نريد تطبيق الكود فيه والضغط مرتين على اسم الشيت فى محرر الاكواد لفتح نافذه الاكواد ثم كتابة الكود داخل النافذه ده طبعا على سبيل المثال بالنسبه لاسم الشيت ولكن اختيار الشيت هيكون على اساس اسماء الشيتات الى عندك انت طبعا Worksheet_SelectionChange هنا يتم تنفيذ الامر كلما يحدث تغير داخل النطاق المحدد شكل الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) End Sub Worksheet_Activate هنا يتم تنفيذ الامر كلما يتم الدخول الى الورقه شكل الكود Private Sub Worksheet_Change(ByVal Target As Range) End Sub Worksheet_Deactivate هنا يتم تنفيذ الامر كلما يتم الدخول الى اى ورقه داخل الشيت اى الخروج من الورقه التى بها الكود شكل الكود Private Sub Worksheet_Deactivate() End Sub Worksheet_Change هنا يتم تنفيذ الامر كلما يتم حدوث تغير فى الورقة شكل الكود Private Sub Worksheet_Change(ByVal Target As Range) End Sub Worksheet_BeforeDoubleClick هنا يتم تنفيذ الامر كلما يتم الضغط على زر الماوس الايسر مرتين شكل الكود Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) End Sub Worksheet_BeforeRightClick هنا يتم تنفيذ الامر كلما يتم الضغط على زر الماوس الايمن شكل الكود Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) End Sub انتهينا من معظم احداث الورك شيت ................................................................................................................................................................................................................................................................................... نتناول الان معظم احداث الورك بوك الفرق هنا ان هذا الكود يوضه فى حدث الورك بوك وطالما وضع فى حدث الورك بوك فيكون قابل للتنفيذ على جميع الشيتات الموجوده فى الورك بوك وليس على شيت بعينه لكتابة الكود داخل حدث الورك بوك ندخل الى محرر الاكواد ثم نضغط على ThisWorkbook مرتين ثم ندخل الى نافذة محرر الاكواد ونكتب فيها الكود Workbook_Open هنا يتم تنفيذ الامر عند فتح الملف شكل الكود Private Sub Workbook_Open() End Sub Workbook_BeforeClose هنا يتم تنفيذ الامر قبل غلق الملف شكل الكود Private Sub Workbook_BeforeClose(Cancel As Boolean) End Sub Workbook_BeforeSave هنا يتم تنفيذ الامر قبل حفظ الملف شكل الكود Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) End Sub Workbook_SheetActivate هنا يتم تنفيذ الامر عند التنقل بين اوراق الملف شكل الكود Private Sub Workbook_SheetActivate(ByVal Sh As Object) End Sub Workbook_AfterSave هنا يتم تنفيذ الامر بعد حفظ الملف شكل الكود Private Sub Workbook_AfterSave(ByVal Success As Boolean) End Sub Workbook_SheetBeforeDoubleClick هنا يتم تنفيذ الامر كلما يتم الضغط على زر الماوس الايسر مرتين فى كل اوراق الملف شكل الكود Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) End Sub Workbook_SheetBeforeRightClick هنا يتم تنفيذ الامر كلما يتم الضغط على زر الماوس الايمن فى كل اوراق الملف شكل الكود Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) End Sub Workbook_NewSheet هنا يتم تنفيذ الامر كلما يتم اضافة ورقه جديده شكل الكود Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) End Sub Workbook_SheetChange هنا يتم تنفيذ الامر عند حدوث تغير فى اى ورقه من اوراق العمل شكل الكود Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) End Sub Workbook_SheetSelectionChange هنا يتم تنفيذ الامر عند حدوث تغير فى نطاق المحدد فى اى ورقه من اوراق العل شكل الكود Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) End Sub انتهينا من معظم احداث الورك شيت ............................................... طبعا فى كتير بيسأل دلوقتى احنا استفدنا ايه من الاكواد دى ولو عايزين نستخدمها هنستخدما ازاى امثـلـــــــــــــــــــــــه عـمـلـيـــــــــــــــــــــه Worksheet_SelectionChange نفترض اننا عايزين حينما يتم التنقل فى الخلايا من a3:a10 يتم ادخال رقم الصف فى الخليه المقابله فى العمود2 يعنى لما ننتقل الى الخليه a3 يتم كتابة رقم الصف فى الخليه b3 ولما ننتقل فى a4 يتم ادخال رقم الصف فى b4 وهكذا كيف نستطيع ان نقوم بعمل ذلك جرب استخدام الكود الاتى Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 10 Then Exit Sub ' فى حالة ان السطر اكبر من 10يتم الخروج من الكود وعدم تنفيذ شئ If Target.Column = 1 Then 'فى حالة العمود الاول If Target.Row >= 3 Then 'فى حالة ان السطر اكبر من او يساوى السطر3 Target.Offset(0, 1).Value = Target.Offset(0, 0).Row ' يتم اعطاء الخليه التى تلى خلية ادخال البيانات بعمود رقم السطر الحالى End If End If End Sub Worksheet_Change نفترض اننا عايزين حينما يتم الكتابه فى الخلايا من a3:a10 يتم ادخال رقم الصف فى الخليه المقابله فى العمود2 يعنى لما نكتب فى الخليه a3 يتم كتابة رقم الصف فى الخليه b3 ولما نكتب فى a4 يتم ادخال رقم الصف فى b4 وهكذا كيف نستطيع ان نقوم بعمل ذلك جرب استخدام الكود الاتى Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Row > 10 Then Exit Sub ' فى حالة ان السطر اكبر من 10يتم الخروج من الكود وعدم تنفيذ شئ If Target.Column = 1 Then 'فى حالة العمود الاول If Target.Row >= 3 Then 'فى حالة ان السطر اكبر من او يساوى السطر3 Target.Offset(0, 1).Value = Target.Offset(0, 0).Row ' يتم اعطاء الخليه التى تلى خلية ادخال البيانات بعمود رقم السطر الحالى End If End If End Sub Worksheet_Activate نفترض اننا عايزين اول ما ندخل على الشيت رقم 3 يتم ظهور رسالة ترحيب كيف يتم عمل ذلك جرب وضع الكود الاتى فى حدث الشيت رقم 3 Private Sub Worksheet_Activate() MsgBox "ابراهيم محمد" End Sub Worksheet_Deactivate نفترض اننا عايزين او ما نخرج من الشيت رقم3 ونروح لاى شيت اخر يتم ظهور رسالة ترحيب كيف يتم عمل ذلك جرب وضع الكود الاتى فى حدث الشيت رقم 3 Private Sub Worksheet_Deactivate() MsgBox "ابراهيم محمد" End Sub Worksheet_BeforeDoubleClick نفترض اننا عايزين لما نضغط فى دبل كليك فى العمود الاول فقط تظهر لنا رسالة ترحيب كيف يتم عمل ذلك جرب وضع الكود الاتى فى حدث الشيت رقم 3 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column > 1 Then Exit Sub If Target.Column = 1 Then MsgBox "ابراهيم محمد" End If End Sub هذا على سبيل المثال يمكنك اضافة الاكود التى تريدونها على حسب احتياجكم اتمنى ان يكون الدرس مفيدا مرفق شيت اكسيل به التطبيقات learnvba.rar تقبلوا تحياتى learnvba.rar

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

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

. نعم يمكن عمل هذا ، بإتباع التعليمات حسب ما وضحت في الرابط اعلاه http://www.officena.net/ib/topic/59661-الأكسس-32-بت،-64-بت/#comment-398477 في الرابط التالي توضيح من مايكروسوفت https://msdn.microsoft.com/en-us/library/office/gg264421.aspx . . الظاهر اني لم اشرح نفسي بشكل واضح في الرابط السابق ، مما نتج عنه هذا المفهوم الخاطئ ، فانا اعتذر عن هذا جعفر بل انا الذي اعتذر علي عدم فهمي لما تقصده استاذي جعفر فالتلميذ هو من يعتذر وليس الاستاذ بارك الله فيكم وفي علمكم

الاخ ياسر البرامج على رابط اخر للامان http://www.4shared.com/rar/APhMrcOmce/GIFAnimator.html? http://www.4shared.com/zip/N9OjU6Wtce/PaintNET3510Install.html? انا شرحهم على فيديوهات بابحث عنها الموضوع من عام ونصف وزى ماقلت كانو على الهارد الذى تم فورمته انا بقالى يومين بجمع فى البرامج والصور

يلا بقي مش مشكلة كنا عاوزين نخدم بس ابو براء سباق في الخيرر حلوة اوي قاعدة IF شغالة مش بتقول لا ابدا

غير بقا رقم 60 دا للقب الجميل الخاص بك الحمد لله أن تم المطلوب على خير والحلو كمل

جعل ما تقومون به في ميزان حسناتكم

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

الاخ جلال تم تغيير مجموعة من الصور وتحديثها لتلف الروابط وبعض الفيديوهات انظر الصورة المرفقة اذا لم تشاهد اى صورة او فيديو او رابط غير المتصفح الصورة المرفقة بالاسفل من الصفحة رقم 2

السلام عليكم ورحمة الله وبركاته استاذى الغالى هذا من بعض من عندكم بارك الله فيك وجزاك عنى خيرا واليك رابط لموضوع كنت قد طرحته من فتره فى المنتدى يشبة نفس الموضوع اكسيلا بنسبة 100% وان اختلفت فقط الفكره http://www.officena.net/ib/topic/55904-استخدام-الدالة-vlookup-من-الواقع-العملى-لقائمة-اسعار/

سأقوم ببعض التغييرات علي الملف هعملها بطريقة تانية كدا يمكن تظبط عندك وياريت الاخوة اللي جربو الملف هل اشتغل تمام ولا نفس المشكلة؟؟؟

استاذنا الحبيب ياسر خليل واحشنى تشجيعك لى والله ربنا يبارك فى حضرتك

أخي الكريم جرح العراقي يرجى فيما بعد وضع عنوان مناسب للموضوع ..يمكنك التعديل لعنوان ملائم ..مثلاً (تحويل ملف إكسيل إلى ملف فوكس برو DBF) عموماً قم بعملية بحث مطورة وتحصلت على كود يؤدي الغرض إن شاء الله كما أنه توجد برامج تقوم بهذه المهمة إليك الكود التالي ..لاحظ أن هناك بعض المكتبات يجب إضافتها ليعمل الكود المكتبات موجودة في بداية الكود ، وتكون الإضافة عن طريق Tools ثم References جرب الكود .. 'References: '*********** 'Microsoft ActiveX Data Objects Library 'Microsoft ADO Ext. 6.0 for DDL and security 'Microsoft Scripting Runtime '-------------------------------------------- Sub ExportToDBF() Dim FileName As Variant Dim Temp As Variant Dim CurrentFile As String Dim DefaultFile As String Dim sPath As String sPath = ThisWorkbook.Path CurrentFile = ActiveWorkbook.Name Temp = Split(CurrentFile, ".") Temp(UBound(Temp)) = "dbf" DefaultFile = Join(Temp, ".") If DefaultFile = "dbf" Then DefaultFile = ActiveWorkbook.Name & ".dbf" End If FileName = sPath & "\" & DefaultFile If FileName = False Then Exit Sub Call DoSaveDefault(FileName) End Sub Function DoSaveDefault(ByVal FileName As String) Dim Path As Variant Dim File As Variant Dim Tfile As Variant Dim Table As Variant Dim dbConn As ADODB.Connection Path = Split(FileName, "\") File = Path(UBound(Path)) File = Replace(Left(File, Len(File) - 4), ".", "_") & Right(File, 4) Tfile = "__T_DB__.dbf" Path(UBound(Path)) = "" Path = Join(Path, "\") Table = Left(Tfile, 8) FileName = Path & File On Error Resume Next GetAttr FileName If Err.Number = 0 Then Dim mbResult As VbMsgBoxResult mbResult = MsgBox("The file " & File & " already exists. Do you want to replace the existing file?", _ VbMsgBoxStyle.vbYesNo + VbMsgBoxStyle.vbExclamation, "File Exists") If mbResult = vbNo Then DoSaveDefault = False Exit Function Else SetAttr FileName, vbNormal Kill FileName End If End If Err.Number = 0 GetAttr FileName If Err.Number = 0 Then MsgBox "Unable to remove existing file " & File & ".", vbExclamation, "Error Removing File" DoSaveDefault = False Exit Function End If On Error GoTo 0 Set dbConn = New ADODB.Connection dbConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Path & ";Extended Properties=""DBASE IV;"";" Dim DataRange As Range Set DataRange = Selection If DataRange.Areas.Count > 1 Then MsgBox "The command you chose cannot be performed with multiple selections. Select a single range and click the command again.", _ VbMsgBoxStyle.vbCritical, "Error Saving File" DoSaveDefault = False Exit Function End If If DataRange.Cells.Count = 1 Then Dim Row1 As Integer Dim RowN As Integer Dim Col1 As Integer Dim ColN As Integer Dim CellFirst As Range Dim CellLast As Range Row1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlNext).Row Col1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column RowN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ColN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Set CellFirst = ActiveSheet.Cells(Row1, Col1) Set CellLast = ActiveSheet.Cells(RowN, ColN) Set DataRange = ActiveSheet.Range(CellFirst.Address, CellLast.Address) End If Dim I As Long Dim J As Long Dim NumCols As Long Dim NumDataCols As Long Dim NumRows As Long Dim C As Range Dim CreateString As String Dim Fieldpos(), Fieldvals(), Fieldtypes(), Fieldnames(), Fieldactive() NumCols = DataRange.Columns.Count NumDataCols = 0 NumRows = DataRange.Rows.Count ReDim Fieldtypes(0 To NumCols - 1) ReDim Fieldnames(0 To NumCols - 1) ReDim Fieldactive(0 To NumCols - 1) I = 0 For Each C In DataRange.Rows(1).Columns If WorksheetFunction.CountA(C.EntireColumn) > 0 Then Fieldactive(I) = True NumDataCols = NumDataCols + 1 If VarType(C.Value) = vbString Then Fieldnames(I) = Left(Replace(C.Value, " ", "_"), 10) Else Fieldnames(I) = "N" & C.Column End If Else Fieldactive(I) = False End If I = I + 1 Next ReDim Fieldpos(0 To NumDataCols - 1) ReDim Fieldvals(0 To NumDataCols - 1) For I = 0 To NumDataCols - 1 Fieldpos(I) = I Next If DataRange.Rows.Count < 2 Then For I = 0 To NumCols - 1 If Fieldactive(I) Then Fieldtypes(I) = vbString End If Next Else I = 0 For Each C In DataRange.Rows(2).Columns If Fieldactive(I) Then Fieldtypes(I) = VarType(C.Value) End If I = I + 1 Next End If Dim Cat As ADOX.Catalog Dim Tbl As ADOX.Table Dim Col As ADOX.Column Set Cat = New ADOX.Catalog Cat.ActiveConnection = dbConn Set Tbl = New ADOX.Table Tbl.Name = Table For I = 0 To NumCols - 1 If Fieldactive(I) Then Set Col = New ADOX.Column Col.Name = Fieldnames(I) FillColumnType Col, Fieldtypes(I), DataRange.Columns(I + 1) Tbl.Columns.Append Col Set Col = Nothing End If Next On Error Resume Next Cat.Tables.Delete Table On Error GoTo 0 Cat.Tables.Append Tbl Dim RS As ADODB.Recordset Dim R As Range Dim Row As Long Set RS = New ADODB.Recordset RS.Open Table, dbConn, adOpenDynamic, adLockPessimistic, adCmdTable If RS.LockType = LockTypeEnum.adLockReadOnly Then MsgBox "The recordset is read-only.", vbExclamation, "Error Inserting Record" End If For Row = 2 To NumRows Set R = DataRange.Rows(Row) If WorksheetFunction.CountA(R.EntireRow) > 0 Then I = 0 J = 0 For Each C In R.Cells If Fieldactive(I) Then Fieldvals(J) = GetValByVbType(C.Text, Fieldtypes(I)) J = J + 1 End If I = I + 1 Next RS.AddNew Fieldpos, Fieldvals End If Next RS.Close dbConn.Close Dim FS As Scripting.FileSystemObject Set FS = New Scripting.FileSystemObject FS.CopyFile Path & Tfile, FileName Set FS = Nothing Kill Path & Tfile DoSaveDefault = True End Function Function FillColumnType(Col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean Dim GetAdoTypeFromVbType As Boolean Select Case vtype Case vbInteger, vbLong, vbByte Col.Type = adInteger Case vbSingle, vbDouble, vbDouble FillColNumberType Col, colrange Case vbCurrency Col.Type = adCurrency Case vbDate Col.Type = adDate Case vbBoolean Col.Type = adBoolean Case vbString FillColStringType Col, colrange Case Else Col.Type = adWChar Col.Precision = 32 End Select GetAdoTypeFromVbType = True End Function Function GetValByVbType(ByVal s As String, ByVal T As Long) Dim Result As Variant Result = Null On Error Resume Next Select Case T Case vbInteger, vbLong, vbByte Result = CInt(s) Case vbSingle, vbDouble, vbCurrency, vbDecimal If CInt(s) <> CDec(s) Then Result = CDec(s) Else Result = CInt(s) End If Case vbDate Result = CDate(s) Case vbBoolean Result = CInt(s) <> 0 Case vbString Result = s Case Else Result = Null End Select On Error GoTo 0 GetValByVbType = Result End Function Function FillColStringType(Col As ADOX.Column, R As Range) As Boolean Dim Lenshort As Long Dim Lenlong As Long Dim L As Long Dim C As Range Lenshort = Len(R.Cells(2).Text) Lenlong = Lenshort For Each C In R.Cells If C.Row > 1 Then L = Len(C.Text) If L < Lenshort Then Lenshort = L End If If L > Lenlong Then Lenlong = L End If End If Next If Lenlong > 254 Then Col.Type = adLongVarWChar ElseIf Lenlong > 128 And Lenlong < 255 Then Col.Type = adWChar Col.Precision = 254 ElseIf Lenshort = Lenlong And Lenlong < 17 Then Col.Type = adWChar Col.Precision = Lenlong Else Col.Type = adWChar Col.Precision = CeilPow2(Lenlong) End If FillColStringType = True End Function Function FillColNumberType(Col As ADOX.Column, R As Range) As Boolean Dim HasDecimal As Boolean Dim T As Boolean Dim C As Range HasDecimal = False On Error Resume Next For Each C In R.Cells If C.Row > 1 Then T = Val(C.Text) <> Int(Val(C.Text)) If Err.Number = 0 And T Then HasDecimal = True Exit For End If End If Next On Error GoTo 0 If HasDecimal Then Col.Type = adNumeric Col.Precision = 11 Col.NumericScale = 4 Else Col.Type = adInteger End If FillColNumberType = True End Function Function CeilPow2(x As Long) Dim I As Long I = 2 Do While I < x I = I * 2 Loop CeilPow2 = I End Function تقبل تحياتي

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

تفضل أخى انظر هذا التعديل ووافنى بالنتيجة mezan.rar

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

الاخ وائل الاسيوطي ارجوا ان يكون هذا المثال يفي بالغرض لو في اي ملاحظات انا موجود aseel.rar

الاخت ام عبدالله شكرا لك واليك لعبة اخرى لعبة الصورة المتحركة2.rar

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

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

أستاذ أحمد أشكرك على المرور الذي يشير إلى أنك مشغول أو مستعجل بارك الله فيك الملف المرفق لم يفي بالغرض المطلوب!! أنا أريد الكود الذي يكتب في VBE إذا كان ذلك بوسعك ثم إن المعادلة في B2 أعطت الخطأ Value ياريت أشوف ردك مرة تانية بس بشرط متكونش مستعجل المرة دي متسني على أحر من الجمر ، فياريت بسرعة وعلى مهلك خالص ... عاشق الإكسيل

السلام عليكم جمعة مباركة دالة استخراج اسم ولي الامر الجديدة ================== ' بسم الله الرحمن الرحيم " '======================================" ' دالة استخراج اسم ولي الأمر " '======================================" 'تلقائية الاستخدام : تقوم بإستخراج الاسم " ' تلقائياً حسب معايير معرفة لديها " '======================================" 'بالإختيار : تقوم بإستخراج الاسم " ' رقما يحدد KhIndex حسب التعيين في " ' ( بعد كم فراغ يستخرج الاسم المطلوب ؟ )" '======================================" Function Father_Name(Name As Variant, Optional KhIndex) As Variant Dim KhString, SearchChar, KhMyNo, KhMyNo1 Dim KhMyLen As Integer KhString = Trim(Name.Value) KhMyLen = Len(KhString) SearchChar = " " If InStr(1, KhString, SearchChar, 1) = 0 Then Father_Name = "": GoTo 3 If Not IsError(KhIndex) Then KhMyNo = 1 For R = 2 To KhIndex KhMyNo1 = InStr(KhMyNo, KhString, SearchChar, 1) + 1 KhMyNo = KhMyNo1 Next KhMyNo1 = InStr(KhMyNo, KhString, SearchChar, 1) + 1 Father_Name = Mid(KhString, KhMyNo1, KhMyLen) Else KhMyNo = InStr(1, KhString, SearchChar, 1) + 1 KhMyNo1 = InStr(KhMyNo, KhString, SearchChar, 1) + 1 If Mid(KhString, 1, 4) = "عبد " Or _ Mid(KhString, 1, 4) = "أبو " Or _ Mid(KhString, 1, 4) = "ابو " Or _ Mid(KhString, KhMyNo, 5) = "الله " Or _ Mid(KhString, KhMyNo, 6) = "الدين " Then Father_Name = Mid(KhString, KhMyNo1, KhMyLen) Else Father_Name = Mid(KhString, KhMyNo, KhMyLen) End If End If 3 End Function fname2.rar

مثال مرفق LaborNameSplit.rar

رائـع ، وبارك الله فيك