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

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

جرب ذلك لعله يكون المطلوب تحياتي اضافة.rar

بسم الله الرحمن الرحيم الحمد لله فقد انتهيت من اعداد النسخه الاولى من برنامج للحسابات باربعة مستويات البرنامج يعمل بدليل للحسابات--ومراكز التكلفه--واسعار صرف للعملات يرجى من الاخوه الخبراء والاعضاء تقيم البرنامج بشكل جيد ان شاء الله يتم تحديث البرنامج مرفق شكل البرنامج وكيفية العمل عليه ACC PRO-first edittion.rar تقبلوا تحياتى

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

السلام عليكم و رحمة الله و بركاته بارك الله في حضراتكم و اصبحكم و امساكم بكل خير

تفضل حبيبي

وعليكم السلام استعملت: ---------------------------------------------- 3. اعمل وحدة نمطية ، مثلا function make_shortcut() الكود يأتي هنا end function ثم اعمل ماكرو ، واطلب من الماكرو ان: شغل الكود make_shortcut شغل النموذج الفلاني ---------------------------------------------- فك المرفق في مجلد واحد ، وافتح البرنامج بطريقة عادية ، واغلق البرنامج ، سترى الاختصار على سطح المكتب ، ومن الان فصاعدا استخدمه للدخول لبرنامجك وكلما حذفت الاختصار ، سيتكون من جديد جعفر Export to Excel And Make Dektop shortcut.zip

اي ID شغال دوس اي حاجه اخي الغالي مش بيقول لا تمام مثل ما ذكر اخي الغالي ابراهيم

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

السلام عليكم اخي الكريم شاهد المرفق كشف حساب العميل تعديل1.rar

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

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

تفضل اخر الكريم جرب البرنامج التالى لو عجبك ارسلك نسخه 2016 المستخدم الدعم الفنى الباسورد 123 ( يمكنك تغيير بنفسك ) تقبل تحياتى برنامج EMA 2015م.zip

السلام عليكم ورحمة الله وبركاته هذا الموضوع اُثير اكثر من مرة في الآونة الاخيرة ، ورأيت من الافضل ان اضع مثال ليقتدي به الجميع وقبل ان نبدأ ، اود ان اشير الى انني اعمل على اكسس 32 بت ، ولا املك نسخة من اكسس 64 بت احب ان اشير الى الرابط الذي شرحت فيه ان مايكروسوفت توصي بتنصيب الاوفيس / اكسس 32 بت ، بغض النظر عن نوع الوندوز المنصّب على الكمبيوتر ، سواء كان 32 بت او 64 بت: http://www.officena.net/ib/topic/64036-هل-استخدم-اوفيس-32-بت-او-64-بت/ ولكن ، ماذا نفعل اذا عملنا برنامجنا على اكسس 32 بت ، واتضح ان الزبون عنده جهاز فيه اكسس 64 بت المثال التالي يشتغل على 32 بت و 64 بت ، ونستطيع ان نستفيد منه لعمل برنامجنا البرنامج المرفق ، بعد فك الضغط ، سيحتوي على 3 برامج: . هذا برنامج No_Password_BE.accdb ، وبه جدول واحد ، ولا يحتاج الى كلمة سر لفتحه: . هذا برنامج Password_is_jj_BE.accdb ، وبه جدول واحد ، وكلمة السر لفتحه هي jj: . البرنامج: JStreetAccessRelinker2.accdb من الرابط http://www.jstreettech.com/downloads.aspx ، وبه ماكرو ووحدات نمطية تعمل على 32 بت و 64 بت (فالفضل في هذا المثال يعود للبرنامج وليس لي ) ، وقد قمت بإضافة نموذج لربطه مع احد برنامج الجداول اعلاه ، ومبدئيا فهو مرتبط مع البرنامج No_Password_BE.accdb ، . وعند فتح البرنامج لأول مرة ، سوف يفتح نافذة تطلب معرفة مكان برنامج الجداول No_Password_BE.accdb ، وتستطيع ان تنقر على الزر Link Another BE ، وستفتح لك نافذة تطلب منك معرفة مكان برنامج الجداول الجديد الذي تريد ان تربطه (بدل البرنامج No_Password_BE.accdb) : . وبما ان البرنامج هذا محمي بكلمة سر ، فسوف تظهر لك نافذة لإدخال كلمة السر (لاحظ ان الادخال مشفر) : . وعندما يتم الربط ، سترى رسالة التاكيد: . الرجاء من الشباب الذين لديهم نسخة من الاكسس 64 بت ، التاكد من ان البرنامج يشتغل على كمبيوترهم بدون اخطاء. عندما نريد ان نعمل برنامج يشتغل على النسختين 32 و 64 بت ، فكود النماذج هو نفسه بين نسختي 32 بت و 64 بت ، والشئ الوحيد الذي يتغير هو دوال الوحدات النمطية API ، والكود الذي ينادي هذه الوحدات (بغض النظر سواء كان في نموذج او في وحدة نمطية مستقلة) ، هنا سوف اعطي مثال واحد من الكود عن طريقة العمل للنسختين 32 و 64 بت: الكود التالي يستعمل دالة API فتح نافذة اختيار ملف ، والدالة هي 32 بت (لاحظ comdlg32.dll ) : Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long الان اذا اردنا ان نجعل هذه الداله API تعمل على 64 بت كذلك ، فالكود يجب ان يكون: #If VBA7 Then 'هذه لنسخة 64 بت Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean #Else 'وهذه لنسخة 32 بت Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long #End If ولاحظ في كود البرنامج ، انه تم جمع جميع الدوال مع بعض ، وجمعها في if# و else# و end if# واحدة. وهناك اصدار جديد لكود الربط ، ويمكن انزاله من هنا: http://www.jstreettech.com/files/JStreetAccessRelinker2.zip جعفر 238.Work_on_32Bits_and_64Bits.zip

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

السلام عليكم ورحمة الله وبركاته مرفق ثلاث ملفات اثنان للترقيم التلقائي بالأكواد وواحد بالمعادلات بمجرد الكتابة في الخلية B يتم نزول الترقيم تلقائي كود ترقيم تلقائي 3.rar ترقيم تلقائي 4.rar ترقيم تلقائي بالمعادلة.rar

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

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

جزاك الله خيرا اخى الكريم فعلا هذا هو المطلوب

تفضل التاريخ التاريخ.rar

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

السّلام عليكم و رحمة الله و بركاته عزيزي الغالي " وائل الأسيوطي " .. إسألْ مجرّبْ و لا تسألْ طبيبْ .. عليك بالوصفة السحريّة ذات المفعول الشّافي و الكافي ..في العيادة على العنوان التالي : http://www.officena.net/ib/topic/65630-%D8%A7%D9%84%D8%B1%D8%AF%D9%88%D8%AF-%D9%88%D8%A7%D9%84%D8%A7%D8%B3%D8%AA%D9%81%D8%B3%D8%A7%D8%B1%D8%A7%D8%AA-%D8%B9%D9%86-%D8%AF%D8%B1%D9%88%D8%B3-%D8%A7%D9%84%D9%81%D9%8A%D8%AC%D9%88%D8%A7%D9%84-%D8%A8%D9%8A%D8%B3%D9%836-%D9%88%D8%A7%D9%84%D8%A7%D9%83%D8%B3%D9%8A%D9%84-%D9%8A%D8%A7%D8%B3%D8%B1-%D8%A7%D9%84%D8%B9%D8%B1%D8%A8%D9%8A/?page=5 فائق إحتراماتي

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

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

اللي يريحك

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

السّلام عليكم و رحمة الله و بركاته معذرةً أستاذي القدير " ياسر العربي " .. قدّمت إقتراح لهذا الموضوع الذي بغير محلّه بنفس الوقت معك بموضوع آخر مستقل .. لم أنتبه لذلك إلاّ بدخولي لسلسلة المناقشات بموضوعنا الشّامل فائق إحتراماتي

السّلام عليكم و رحمة الله و بركاته أخي الكريم "YES14" ..قمت بتغيير في الفورم و الكود .. محاولة بسيطة منّي على السّريع لعلّها تفي بالغرض .. ملاحظة : خالفتَ بتصرّفك قواعد المنتدى أخي الكريم فائق إحتراماتي جديد.rar

مع انه مش موضوعنا بس تفضل حبيبي مش هرجعك فاضي ومرحب بيك في اسرة اوفيسنا يرجى قراءة التوجيهات بالمنتدى وتغيير اسم الظهور للغة العربية وشكرا جديد.rar

لو متابع جيد هتلاقي ان كاتب لو الايقونات اكبر من ٣٢bit كعمق الوان لن تضاف ارجع لايقونات اقل شويةاو تشوف برامج تحويل الايقونات هي بالفعل 32 رأيتها الان ولكن يوجد بعض الايقونات التي لا تعمل مع الفيجوال يرجى البحث عن ايقونات بديلة او برامج لتحويل الايقونات

تفضل استاذنا الغالي ابراهيم ابو ليله خصائص مباشرة لا انما ممكن تتعمل بكذا طريقة بالاكواد منها علي سبيل المثال (مرفق) والتنقل بين الازرار اما بالتاب او بالاسهم عادي ولا شئ مستحيل في الفيجوال :) New folder.rar

ربنا يحفظك ويبارك فيك ماقصرت كفيت ووفيت

ماقصرت تشكر ربنا يحفظك

معلش العتب على نظرى تقبل تحياتى

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

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

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

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

شكرا على التصحيح الفني ولكني اللي فهمته ان #If VBA7 Then 'هذه لنسخة 64 بت Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean #Else 'وهذه لنسخة 32 بت Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long #End If سيجعل الكود يعمل على 32بت (والذي يعمل عندي) و 64بت (كما اكده الاخ كرار karrar sabry). ورجوعا الى رابط تعديل الكود بين 32بت و64بت ، وجدت هذه الملاحظة : 'This is one of the few API functions that requires the Win64 compile constant: #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr #Else Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr #End If #Else Private Declare Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long #End If جعفر

السلام عليكم البرنامج عند إعداده set Up يطلب product ID ولا أدري كيف أضعه وهو غير كلمة المرور التي ذكرتها.. تقبل تحياتي.

السلام عليكم ورحمة الله اخي كاسر الامواج متأسفين جدا لطول إنتظارك وجبر الخواطر علي الله تفضل إليك الملف 1- تم إلغاء التعديل بالكامل وتعليق الإضافة بعدم ظهور زر الجديد 2- تم إضافة العمود الرابع 3- يتم عمل البحث بواسطة إسم المنطقـــــــــــــــــــــــــــــــــــــــــــــــــة عن طريق الكمبوبكس 4- البحث بإختيار اسم المنطقة من الكمبوبكس وتستطيع الكتابة يدويا بس تنتبه فالبحث حساس جدا لانة يعمل مقارنة لكي يحدد الشيت ثم الصف ثم الخلية التي تقابل مابحثت عنة لذلك قمت بإستبدال التكست بكس بالكمبوبكس واسندت إلية اسماء المناطق لكي يكون دقيق في المقارنة تستطيع سجلات جديدة حتى الف إسم بعد البحث يقوم بنقلك الي عنوان الويب اخوكم في الله / ابو الحسن والحسين KHMB ادخال بيانات.rar

نعم هذا صحيح ، هو اختصار للبرنامج وهو غلط اصلا انك تضع البرنامج على سطح المكتب ، والذي يسهل حذفه وبسهولة ، بينما بتغيير في الكود أعلاه ، تستطيع ان تجعل الكود يتأكد من وجود الاختصار على سطح المكتب ، وان لم يوجد (يعني اذا المستخدم حذفه لأي سبب) ، فالكود يصنعه مرة ثانية جعفر

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

أهلا بك أستاذ عصام فى أوفيسنا . جرب الكود التالى Sub WorksheetSizes() Dim C As Range, Sh As Worksheet Dim Wb As String, Temp As String, sReport As String Application.ScreenUpdating = False Application.DisplayAlerts = False sReport = "حجم الأوراق" Wb = "mokhtar.xlsx" Temp = ThisWorkbook.Path & Application.PathSeparator & Wb On Error Resume Next Set Sh = Worksheets(sReport) If Sh Is Nothing Then With ThisWorkbook.Worksheets.Add(Before:=Worksheets(1)) .Name = sReport .Range("A1").Value = "اسم الشيت" .Range("B1").Value = "الحجم بالبايت تقريباً" End With End If On Error GoTo 0 With ThisWorkbook.Worksheets(sReport) .Select .Range("A1").CurrentRegion.Offset(1, 0).ClearContents Set C = .Range("A2") End With For Each Sh In ActiveWorkbook.Worksheets If Sh.Name <> sReport Then Sh.Copy ActiveWorkbook.SaveAs Temp ActiveWorkbook.Close SaveChanges:=False C.Offset(0, 0).Value = Sh.Name C.Offset(0, 1).Value = FileLen(Temp) Set C = C.Offset(1, 0) Kill Temp End If Next Sh Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

تفضل أخي صابر انت تختار الملف ، ويقوم الكود بالباقي الكود هو: Dim TextLine, File_Name, File_ext, Folder_Name, nFile_Name File_Name = Dir(Me.txtPath) 'the file name only File_ext = Mid(File_Name, InStrRev(File_Name, ".") + 1) 'the file extension Folder_Name = Replace(Me.txtPath, File_Name, "") 'the folder name 'a temp csv file to transfer to it the correct lines nFile_Name = Folder_Name & Mid(File_Name, 1, Len(File_Name) - Len(File_ext) - 1) & "_2." & File_ext 'open both Input and Output files Open Me.txtPath For Input As #1 Open nFile_Name For Output As #2 i = 0 Do While Not EOF(1) ' Loop until end of file. Line Input #1, TextLine ' Read line into variable. i = i + 1 'skip the 1st 3 lines, and write the rest If i >= 4 Then Print #2, TextLine End If Loop Close #1 Close #2 'now we have a csv file correctly saved, 'convert it to xls 'make reference to Microsoft Excel xx.x object Library Dim wBook As workbook Set wBook = Workbooks.Open(nFile_Name, Format:=6, Delimiter:=",") wBook.SaveAs Replace(Me.txtPath, ".csv", ".xls"), FileFormat:=xlExcel8 wBook.Close False 'delete the temp cvs file Kill nFile_Name جعفر 298.Remove_3_Lines_csv.mdb.zip

السلام عليكم حط الكود التالي في حدث Thisworkbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Column = 9 And Target.Row > 1 Then Ali Target End Sub والكود التالي في مودويل Public Sub Ali(ByVal Tr As Range) Dim A As String Dim R As Range Dim Sht As Worksheet With Tr On Error GoTo Nx Set Sht = Sheets(.Text) 2 With ActiveSheet.Range("A" & .Row & ":I" & .Row) .Copy With Sht .Cells(.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row, 1).PasteSpecial xlPasteValues End With .ClearContents End With Application.CutCopyMode = False End With Set Sht = Nothing: Set R = Nothing Exit Sub Nx: Set Sht = Sheets("Main") GoTo 2 End Sub

يجب ان يوضع الكود بهذه الصيغة Sub set_active_sheet() Dim sa As Worksheet If ActiveSheet.Name = "sheet1" Then Set sa = Sheets("sheet1") Else Set sa = Sheets("sheet2") End If sa.Activate lr = ActiveSheet.Cells(Rows.Count, 1).End(3).Row End Sub

السلام عليكم انسخ الكود التالي الى حدث الورقة المسماه "الصفحة 2" Private Const My_Rng_Adrs As String = "$A$3:$D$55000" Private Const Area_Prnt As String = "$C$7:$E$15" Dim Ar_1() As Variant Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Range("A7:A1000"), Target) Is Nothing Then MsgBox "" If Target <> Empty Then Dim Wr As Worksheet: Set Wr = Sheets("الصفحة 3") With Wr .Cells(7, 4) = Target .Cells(8, 4) = Target.Offset(0, 1) .Cells(9, 4) = Target.Offset(0, 2) .PageSetup.PrintArea = Area_Prnt .PrintPreview .Cells(7, 4) = "": .Cells(8, 4) = "": .Cells(9, 4) = "" End With Cancel = False Set Wr = Nothing End If End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 1) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$C$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CDate(Target), 3) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If If Target.Address = "$E$5" Then Range(Range("A7"), Range("D7").End(xlDown).Resize(1, 4)).ClearContents If Ali_Serch(CStr(Target), 4) = True Then Range("A7").Resize(UBound(Ar_1, 1), UBound(Ar_1, 2)) = Ar_1() End If Erase Ar_1 End If End Sub Private Function Ali_Serch(Trget As String, Col As Long) As Boolean Dim Ar Dim Rng As Range Dim C, x, i, XX, Xi, Xt Dim Data_1 Dim Wrsh As Worksheet Set Wrsh = Sheets("الصفحة 01") With Wrsh If Col = 3 And Not IsDate(Trget) Then MsgBox "صيغة التاريخ التي كتبتها غير صحيحه !!", vbExclamation, "إدخال خاطئ !!": Exit Function Set Rng = .Range(My_Rng_Adrs) Ar = Rng.Value ReDim Preserve Ar_1(1 To Rng.Rows.Count, 1 To 4) For x = LBound(Ar, 1) To UBound(Ar, 1) XX = Ar(x, Col): Xi = Trim(Ar(x, 1)): Xt = Trim(Ar(x, 2)) If Col = 3 Or Col = 4 Then Data_1 = Val(XX) ElseIf Col = 1 Then Data_1 = CStr(Xi & " " & Xt) ElseIf Col = 3 Then Data_1 = CDate(DateSerial(Year(XX), Month(XX), Day(XX))) End If If Not Data_1 = Empty Then If Data_1 Like Trget Then Ali_Serch = True i = i + 1 For C = 1 To 4 Ar_1(i, C) = IIf(C = 3, Format(Ar(x, C), "dd/mm/yy"), CStr(Ar(x, C))) Debug.Print Ar(x, C) Next C End If End If Next x End With Set Rng = Nothing: Set Wrsh = Nothing End Function بعد كتابة الاسم او التاريخ او رقم التسجيل اضغط انتر ستظهر النتائج اسفل جدول البحث انقر مرتين على نتيجة البحث في العمود "A" الاسم الاول سيطبع لك النتيجه جرب وابلغنا بالنتائج تحياتي تم اضافة المرفق وبه الكود اعلاه تجربة_111.rar

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

السلام عليكم =========== انظر المرفق ترتيب تصاعدى وتنازلى بالمعادلات.rar