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

السلام عليكم ورحمة الله وبركاته شرح عمل نطاق ديناميكي أو قائمة مطاطية Dynamic Range أول شيء سنقوم به هو تسمية نطاق أرقام الجلوس ، وهنتعلم إزاي نخلي النطاق ديناميكي يعني مش ثابت من خلية محددة إلى خلية أخرى محددة ، كل اللي هنعمله إننا هنحدد أول خلية ، أما آخر خلية به رقم جلوس فدي هتتحدد بشكل ديناميكي ؛ عشان لو زودت أرقام جلوس يتغير النطاق بدون تدخل منك >> بندخل على التبويب Formulas ثم Name Manager ونضغط New (سأقوم بحذف كل النطاقات الغير هامة أو مكررة) ونكتب في حقل Name اسم النطاق هنسميه (رقم_الجلوس) ، وفي الحقل المسمى Refers to هنكتب المعادلة بهذا الشكل : ='كنترول شيت'!$B$11:INDEX('كنترول شيت'!$B$11:$B$500,COUNTA('كنترول شيت'!$B$11:$B$500)) الجزء الأول في المعادلة بيحدد بداية النطاق ألا وهو الخلية B11 وبما إن خلية البداية لازم تكون ثابتة فبنضيف علامات الدولار قبل اسم العمود ورقم الصف لتصبح بهذا الشكل $B$11 نلاحظ في المعادلة إنه بيتم الإشارة إلى ورقة العمل اللي فيها النطاق ، وورقة العمل هي "كنترول شيت" ، والتي تحتوي على أرقام الجلوس في العمود B بداية من الخلية B11 بعدما حددنا خلية البداية وضعنا : (نقطتين فوق بعض) عشان الجزء اللي ورا النقطتين فوق بعض هو دا المسئول عن تحديد آخر خلية في النطاق الجزء الثاني في المعادلة (المسئول عن البحث عن آخر رقم جلوس في النطاق) INDEX('كنترول شيت'!$B$11:$B$500,COUNTA('كنترول شيت'!$B$11:$B$500)) الدالة INDEX دالة فهرسة أو بحث ، ودي ليها ثلاثة بارمترات : ** البارامتر الأول عبارة عن مصفوفة لقيم النطاق .. يعني لو خدنا السطر السابق ووضعناه في خلية ووضعنا علامة يساوي قبله (الناتج هيكون آخر رقم جلوس في النطاق) ولو جينا بعد القوس المفتوح بعد اسم الدالة INDEX ووضعنا مؤشر الكتابة بيظهر تلميح مع المعادلة .. هتلاقي كلمة Array في التلميح بلون أسود عريض Bold انقر عليه بالماوس ، هيحدد لك في المعادلة مصفوفة القيم اللي هي في مثالنا 'كنترول شيت'!$B$11:$B$500 هو دا نطاق أرقام الجلوس .. واستخدمنا هنا رقم 500 كحد أقصى للبيانات ، ممكن نغير رقم 500 إلى أي رقم أكبر زي 1000 أو أكتر .. نيجي نضغط F9 من لوحة المفاتيح بعد ما حددنا الجزء ده في المعادلة هنلاقي قيم النطاق بالكامل بما فيها الخلايا الفارغة ، الخلايا الفارغة هتاخد القيمة صفر ، وبقية القيم هي عبارة عن أرقام الجلوس {1983;1984;1985;1986;1987;1988;1989;1990;1991;1992;1993;1994;1995;1996;1997;1998;1999;2000;2001;2002;2003;2004;2005;2006;2007;2008;2009;2010;2011;2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023;2024;2025;2026;2027;2028;2029;2030;2031;2032;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0} هو دا شكل القيم داخل المصفوفة .. طبعاً عشان نلغي اللي عملناه نضغط Ctrl + Z من لوحة المفاتيح للتراجع (الحركة اللي عملناها عشان نفهم شكل المصفوفة التي سيتم البحث داخلها) ** البارامتر الثاني وهو لمعرفة عدد الصفوف ، والمطلوب إننا نجيب عدد الصفوف التي تحتوي على قيم فقط (الخلايا التي تحتوي على قيم دون الأصفار) وهنا تم استخدام دالة COUNTA ودي دالة سهلة لعد القيم دون الفراغات ، وسيتم عد نفس النطاق COUNTA('كنترول شيت'!$B$11:$B$500) ولو ضغطنا F9 من لوحة المفاتيح هنلاقي الناتج لهذا الجزء هو 50 أي أن عدد أرقام الجلوس 50 ** البارامتر الثالث وهو اختياري ولم يتم الإشارة إليه في المعادلة وهو عدد الأعمدة ، ودا هنا الإكسيل بيفهم إن عدد الأعمدة واحد فقط لأننا شغالين على عمود واحد فقط ألا وهو العمود B. لو عايز تعرف شكل النطاق بعد وضع المعادلة ادخل على Name Manager وحدد اسم النطاق (رقم_الجلوس) ثم انقر على كلمة Edit ثم أخيراً انقر على السهم الأحمر على يمين المعادلة ، ستجد أن الإكسيل سيقوم بتحديد النطاق الديناميكي .. قم بإضافة أرقام جلوس أخرى ، وعيد نفس الخطوات وشوف النتيجة بنفسك (ستجد أن النطاق ديناميكي وليس ثابت)

أي توضيح أكثر الذي تقصده أخي الكريم؟؟!! خلينا واحدة بواحدة * في الخلية L3 مكتوب (من هذا الصف يحتسب 21 يوم فقط ابتداء من 02/02/2011) هل معنى هذا أنك تريد معرفة التاريخ الذي يأتي بعد 2/2/2011 بواحد وعشرين ويوم وهو 23/2/2011 أم ماذا؟؟!! * ما المقصود بالمهمة المذكورة في K9 ؟؟!! * في الخلية L11 ما التاريخان المقصودان؟ وأين النطاق الذي تريد عدم احتساب تواريخه؟؟!! ما معنى الأرقام التي مجموعها 300؟؟!! وعلى أي اساس هي الصواب بدلا من 354؟؟ ................... أين تريد وضع المعادلة المطلوبة؟ وماذا تريدها أن تفعل بالتفصيل الممل؟؟!!

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

السلام عليكم مادمت اخذت طريق الاستعلام CrossTab ، فهناك شئ جدا ضروري يجب ان تعرفه ، ولقد كلفني الكثير من العناء والمشقة والتفكير والتصليح والوقت في سبيل معرفته لما تعمل الاستعلام ، فانك تعمل حقل "عناوين الاعمدة" Column Headings ، والعناوين مثل ما ترى هنا ، هي "1-6" و "7-12": واذا القينا النظر الى بيانات الجدول ، سنرى انها تحتوي على بعض الاشهر من 1 الى 12 وعليه ، نتيجة الاستعلام ستكون: ونتيجة النموذج (او التقرير) ستكون: ولكن اذا لم تكن هناك قيمة لأحد الاعمدة (لاحظ في الصورة التالية) ، لقد حذفت سجلات الاشهر من 7 الى 12 من الجدول ، لذا فلا توجد بيانات للعمود 7-12 ، اي لا يوجد حقل اسمه 7-12: فنتيجة الاستعلام ستكون بدون ذلك الحقل (لاحظ عدم وجود عمود اسمه 7-12): ولكن نتيجة النموذج (او التقرير) ستكون: هناك طرق لحل هذه المشكلة: 1. برمجيا عن طريق QueryDef ، بحيث تعيد عمل الاستعلام: TRANSFORM Sum(Table1.ammount) AS Sumمنammount SELECT Year([dates]) AS السنة FROM Table1 GROUP BY Year([dates]) PIVOT IIf(Month([dates]) Between 1 And 6,"1-6","7-12"); وتعدل في عناوين اعمدة الاشهر ، بحيث اذا الاشهر ما موجودة في الجدول ، فانك لازم تحذفها من الاستعلام ، وتعيد حفظ الاستعلام بمعلوماته ، وكود التأكد والتغيير يجب ان تعمله في كل مرة تريد ان تشغل الاستعلام. 2. عند فتح النموذج (او التقرير) : بحيث تضع كود يفحص اذا كان هناك حقل اسمه 7-12 ، فاذا لم يوجد ، فيجب ان تحذف مصدر عنصر الحقل. 3. وهذا ما توصلت اليه أخيرا وبعد مشقة وعناء: في اعدادات الاستعلام ، اكتب اسماء الاعمدة في اعدادات الاستعلام ، وعليه اسماء الاعمدة ستكون دائما موجودة ، بغض النظر اذا كانت هناك بيانات ام لا: ونتيجة الاستعلام: ونتيجة النموذج (او التقرير): جعفر 87.1.Database1.accdb.zip

بسم الله الرحمن الرحيم لاحظت في الفترة الأخيرة كثرة الأسئلة عن موضوع نسيان كلمات مرور ملفات الإكسل أو بعض ورقات العمل بالملف فأحببت أن أشارك إخوتي وأحبّتي أعضاء ومشرفي وخبراء منتدانا الرائع هذه الإضافة MasNoPass لفك حماية أوراق العمل في ملفات الإكسل وتعمدت تسهيل عملها &&&&&&&&&&& فقط تحتاج لإضافة الوظيفة الإضافية: 1 في ويندوز xp نسخ المرفق إلى المسار التالي C:\Documents and Settings\***\Application Data\Microsoft\AddIns حيث أن C هو قرص النظام و *** هو اسم المستخدم 2 في ويندوز 7 نسخ المرفق إلى المسار التالي C:\Users\***\AppData\Roaming\Microsoft\AddIns حيث أن C هو قرص النظام و *** هو اسم المستخدم ****************** بالنسبة لمستخدمي إكسل 2003 من خلال: فتح برنامج الإكسل والضغط على قائمة أدوات tools ===> وظائف إضافية Addins ===> ثم اختر MasNoPass ثم موافق ok وبالنسبة لمستخدمي إكسل 2007 يتم ذلك من خلال : فتح برنامج الإكسل والضغط على زر الأوفيس ثم خيارات إكسل Excel options ثم اختيار وظائف إضافية Addins من الجانب الأيمن/الأيسر ثم اذهب go ثم اختيار MasNoPass ثم موافق ok وبالنسبة لمستخدمي إكسل 2010 وما بعدها يتم ذلك من خلال : فتح برنامج الإكسل والضغط على قائمة ملف file ثم خيارات إكسل Excel options ثم اختيار وظائف إضافية Add-ins من الجانب الأيمن/الأيسر ثم اذهب go ثم اختيار MasNoPass ثم موافق ok /////////////////// طريقة العمل:- بعد تسجيل الوظيفة الإضافية تجد ظهور قائمة جديدة باسم (فك الحماية) وتحتاج فقط إلى فتح الملف المحمي ثم الضغط على قائمة فك الحماية واختيار (إزالة كلمة المرور) بعدها سيتم البدء في عدّ المحاولات والوقت المنقضي في إجراء العملية بعدها تظهر رسالة تفيد أنه تم إزالة كلمة المرور عن الملف وبعد الضغط على الرسالة ستجد الملف مفكوك بين يديك $$$$$$$$$$$$$$$$ و أذكّر نفسي وإياكم بأن الصحابة عليهم رضوان الله كان الواحد منهم إذا أراد أن يدعو لنفسه دعا لأخيه فيقول له الملك آمين ولك مثلها فلا ينقصني سوى دعائكم وأخيرا أذكر بخطورة الموقف وأرجو عدم استعمالها فيما حرّم الله وعند النقل يجب ذكر المصدر منتديات أوفيسنا اللهم قد بلّغت ... اللهم فاشهد أخوكم محمد صالح فيديو لشرح كيفية استعمال الأداة ولا ينقصني سوى دعاؤكم ينصح بالاشتراك في القناة وتفعيل جرس التنبيه ليصلكم كل جديد ومفيد وقت صدوره MasNoPass.rar New_MasNoPass.rar

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

السلام عليكم ورحمة الله وبركاته إخواني الكرام .. قد يكون موضوع الكسر موضوع شائك وفيه خلاف ، ولكن ربما يكون مفيد لصاحب العمل نفسه ، حيث أنه معرض لنسيان الباسورد الذي تم وضعه على محرر الأكواد .. الموضوع مميز لأنه يقوم بكسر الحماية بدون برامج على الإطلاق ..وبدون AddIns وبدون الاستعانة بأية برامج مجانية أو مدفوعة !! كسر محرر الأكواد بالأكواد نفسها (قنبلة الموسم) وعلى رأي المثل : علمته رمي السهام فلما اشتد ساعده رماني .. الكود قليل الأصل !! محفظش الجميل للبيئة اللي هو منها ، لأنه كسر بيئة محرر الأكواد !!! Sub HackVBA() Open "C:\Users\Future\Desktop\Test.xls" For Binary As #1 Put #1, 1, Replace(Input(LOF(1), 1), "DPB=", "DPX=", , 1) Close Workbooks.Open "C:\Users\Future\Desktop\Test.xls" End Sub المطلوب فقط أن تغير مسار الملف المراد كسره داخل الكود ، والمسار يوضع بين أقواس تنصيص .. أترككم مع الفيديو عله ينال إعجابكم وتستفيدوا منه إن شاء المولى .. ولا تنسونا من اللايكات على اليوتيوب !!!!! ....أكرر اللايكات على اليوتيوب ..فضلاً لا أمراً تقبلوا تحيات أخوكم أبو البراء

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

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

أتمنى من الله ان تكونوا في تمام الصحة والعافية موضوع بسيط وجديد على البعض وفائدته أنه يعمل إنتقال من الفريمات الموجودة في اليوزر فورم بشكل غير تقليدي وسلس في المثال المرفق يوجد يوزر فورم وبه عدد 2 Frame ويتم الإنتقال من فريم للأخر بزر عادي ولكن طريقة الإنتقال هي موضوعنا الأكواد المستخدمة أكواد الـ UserForm يحتوي على 2 Command Button لإنتقال من فريم للأخر Option Explicit Private Sub CommandButton1_Click() While Frame2.Left > 6 Frame2.Left = Frame2.Left - 10 DoEvents Sleep 10 Wend End Sub Private Sub CommandButton2_Click() While Frame2.Left < 266 Frame2.Left = Frame2.Left + 10 DoEvents Sleep 10 Wend End Sub Private Sub UserForm_Initialize() Me.Width = 262 Frame2.Left = 266 Frame2.Top = 6 End Sub كود مستخدم في Module عادي Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) أتمنى يكون الموضوع خفيف وواضح والمرفق به التطبيق ودمتم في حفظ الله Sliding Form.rar

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

أخي الكريم .. تمت الإشارة إلى أنه لو هناك طلب جديد فقم بطرح موضوع جديد مع الشرح والتفصيل .. انظر لعدد المشاركات بالموضوع .. وصل لـ 41 مشاركة ..أعتقد كدا كفاية على الموضوع .. ** لا تنسى أن تحدد أفضل إجابة من خلال الضغط على كلمة "تحديد كأفضل إجابة " ؛ ليظهر الموضوع مجاب ومنتهي. ** لا تنسى أن تضغط كلمة "أعجبني هذا" (الأمر لن يستغرق منك ثواني) ---> (أمضيت من وقتي وقتاً ليس بالقليل .. فاضغط ولا تكن بخيل) تقبل تحياتي

أتمنى أن يكون هذا هو المطلوب للعلم يجب تغيير الخلية B3 إلى تاريخ حتى يتم المطلوب وإلا سينتج أرقام عشرية mas_حساب الايام مابين تاريخيين.rar

تفضل اخي الكريم الحل Test 200 salim.rar

الأخ الكريم صلاح الدين سعيد مبروك عليك الاسم الجديد إليك الكود التالي عله يكون المطلوب Sub MyReport() Dim SN, I As Long, J As Long, N As Long Sheets("إجمالي").Range("A1:B1000").ClearContents SN = Sheets("إدخال").Range("H1:AU" & Sheets("إدخال").Cells(Rows.Count, 8).End(xlUp).Row) ReDim Arr(UBound(SN) * UBound(SN, 2), 2) For I = 2 To UBound(SN) For J = 1 To UBound(SN, 2) Step 2 If SN(I, J) <> "" Then Arr(N, 0) = SN(I, J) Arr(N, 1) = SN(I, J + 1) N = N + 1 End If Next J Next I With Sheets("إجمالي") .Cells(2, 1).Resize(N, 2) = Arr .Cells(1, 1) = "اسم الصنف": .Cells(1, 2) = "الكمية المنصرفة" End With End Sub يرجى إذا كان فيه طلب جديد طرح موضوع جديد ..ليكون كل موضوع بطلب مستقل .. هذا لأن طلبك الثاني مختلف عن الأول (لكن عشان جديد وعشان سمعت الكلام وغيرت اسمك للغة العربية .. محبتش أتقل عليك) لا تنسى الالتزام بالتوجيهات على هذا الرابط (من هنا) ، وتحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي Recipe YasserKhalil.rar

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

عسى ان ينال اعجابك منتوجات زراعية.rar

اخي ياسر هذا خيار اخر قمت به جزاك الله خيراً

أخي الغالي سليم لما استخدام الحلقات التكرارية هنا Sub TypeSpecificWord() Range("C2:C" & Rows.Count).ClearContents With Range("C2:C" & Cells(Rows.Count, "B").End(xlUp).Row) .Value = "ناجح" End With End Sub يمكن ببساطة استخدام الكود بهذا الشكل

الموديل هو بشكل general اي انه يعمل مع كل الصفحات فقط قم بتنشيط الصفحة المطلوبة و نفذ فيها الماكرو لتغير النطاقات فقط بدل الاحرف في الكود: مثلاً تبديل B الى M يقوم الماكرو بالتنفيذ على العامود M وهكذا

انسخ هذا الكود الى Module و قم بوضع زر لتنفيذه Sub salim_has() Dim LR As Long Dim Rng As Range, Cell As Range ''''''''''''''''''''''''''''''''''''''''''''''' lrb = Cells(Rows.Count, 2).End(xlUp).Row Set Rng = Sheets("Sheet1").Range("b2:b" & lrb) Range("c2:c" & lrb) = "" '''''''''''''''''''''''''''''''''''''''''' Do While i < lrb - 1 Cells(i + 2, 3).Value = "ناجح" i = i + 1 Loop End Sub

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

نفرض ان تاريخ الميلاد هو اسم مربع النص ضع مربع نص جديد إسمه yearوضع فيه هدا الكود =year([تاريخ الميلاد]) في مربع نص العمر ضع هذا =Year(Date())-([year])

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

جرب الكود بهذا الشكل Sub Transfer() Application.ScreenUpdating = False On Error Resume Next Dim Cell As Range, T As String, LR As Long, LRT As Long Dim WS As Worksheet, Answer As Long Set WS = Sheets("1") LR = WS.Cells(35, 3).End(xlUp).Row T = WS.Range("A3").Value Application.ScreenUpdating = False WS.Unprotect "2191612" If Not IsEmpty(WS.Range("c6")) Then With Sheets(T) .Unprotect "2191612" LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1 WS.Range("B6:G" & LR).Copy .Cells(LRT, 2).PasteSpecial xlPasteValues .Protect "2191612" End With Answer = MsgBox("تم ترحل البيانات .....هل تريد أن مسح البيانات المرحلة؟", vbYesNo + vbQuestion) If Answer = vbYes Then Sheets("1").Activate Sheets("1").Range("A3,C6:C35,F6:G35").Select Selection.ClearContents Else MsgBox "!! لم يتم الحذف" End If Sheets("1").Select ActiveWindow.SmallScroll Down:=-12 Range("A3,C6").Select Else MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub End If WS.Protect "2191612" Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

ايه الحلاوه دي ايه الطعامة دي شرح مفيد وروعه جزاك الله خيرا

عسى ان يكون المطلوب تلوين نطاق بشرط.rar

ابسط طريقة لعمل ذلك بدون اكواد اخفاء محتويات.rar

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

الموضوع الثالث للإطلاع على الموضوع الأول للإطلاع على الموضوع الثاني في الجزء الثالث بمشيئة الله هنتكلم عن جزئية بسيطة ولكنها مهمة بالنسبة للإضافات Addins وهي طريقة التعديل على الإضافة بإضافة أكواد حذف أكواد وهكذا كما أنه لابد أن نذكر أنه يمكن أن تكون الإضافة عبارة عن دالة معرفة User Defined Function (UDF) كالتالي يضعها الإخوة الأفاضل في المنتدى فيمكن الجمع بين عدد غير محدود من المعادلات المعرفة في إضافة واحدة والاستفادة منها بأقصى شكل ممكن مع كل ملفات الإكسل الخاص بك وسوف يتم التطرق لبعض الأمثله بمشية الله . أولا لكي يتم التعديل على الإضافة في وضعها الحالي كإضافة بدون تحويلها إلى ملف إكسل عادي. يتم ذلك بإحدى طريقتين : إذا كانت الإضافة قد تم إضافتها لبرنامج الإكسل وتظهر حاليا في البرنامج فيمكنك في هذه الحالة فتح ملف إكسل فارغ والدخول إلى محرر الأكواد مباشرة ومن ثم التعديل على الإضافة وأخيرا وانت في محرر الأكواد تضغط على Save حتى يتم حفظ التعديلات. إذا لم تكن الإضافة مضافة بالفعل إلى الإكسل فيمكن الضغط عليها مرتين لفتح نافذه الإكسل ومن ثم الدخول إلى محرر الأكود والتعديل ثم الحفظ. ثانيا إذا أردنا تحويل الإضافة إلى ملف إكسل مرة أخرى (( عكس خطوات الموضوع الأول )) فيتم ذلك كالتالي فتح الإضافة بإحدى الطريقتين السابقتين حتى نتمكن من التعديل عليها ثم نطبق الخطوات في الصورة التالية ونحفظ التغييرات سيطلب منك الحفظ باسم جديد حدد الاسم ومكان الحفظ واضغط اوكي وكده ان شاء الله تكون طريقة التعديل على الإضافة وتحويلها مرة أخرى لملف إكسل عادي سهله ومفهومة للجميع. ودمتم في رعاية الله

تفضل يا اخى اخفاء الاعمدة و الصفوف التى مجموعها = صفر اخفاء اعمدة و صفوف مجموعها صفر.rar

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

وهذه تحسين لفكرة اخي الفنان جعفر ! وحسب فهمه ! يعني لو خطأ مالنا شغل ! الصق جملة الاستعلام التالية كمصدر للاستعلام TRANSFORM Sum(Table1.ammount) AS Sumمنammount SELECT Year([dates]) AS السنة FROM Table1 GROUP BY Year([dates]) PIVOT IIf(Month([dates]) Between 1 And 6,"1-6","7-12"); بالتوفيق

جزاكم الله كل خير

ترحيل بيانات بالقائمة المنسدلة للعلامه عبد الله باقشير والمرفق يوضح اكثر ترحيل عن طريق القائمة المنسدله.rar

السلام عليكم ورحمة الله وبركاته أقدم لكم موضوع بسيط جداً ومهم جداً ومفيد جداً ... وإن شاء الله بعد الإطلاع على الموضوع من قبلكم سيتم ضربي ضرباً مبرحاً جداً أكواد البداية والنهاية (على وزن سلسلة البداية والنهاية للعلامة ابن كثير) الموضوع يتلخص في كلمتين .. لما يكون عندك كود بيستغرق وقت طويل في التنفيذ ، دا بيرجع أسبابه لعوامل كثيرة ، لن نتظرق إليها لأنه موضوع يطول شرحه .. فجئت إليكم بحل بسيط وفعال ..الحل كالتالي .. تضع الكود التالي (كود البداية وكود النهاية) في موديول دا كود البداية Public Sub YK_Start() Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False Application.Calculation = xlCalculationManual End Sub ودا كود النهاية Public Sub YK_End() Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub وكلا الكودين مسبوقين بكلمة Public عارفين ليه ؟ عشان تقدر ببساطة تضع الكودين في أي موديول وتستدعيهم من أي موديول آخر كود البداية بيلغي تحديث الشاشة ورسائل التنبيه ويلغي تفعيل الحدث ويخلي الحسابات بشكل يدوي وكود النهاية بيرجع اللي فات للإعدادات الأصلية في الملف المرفق مثال .. كود يقوم بعمل حلقة تكرارية لـ 100000 صف تم استدعاء كود البداية في البداية وكود النهاية في النهاية .. والاستدعاء تم بمحضر من القسم والمحضر مكتوب فيها كلمة واحدة Call يليها اسم الكود المراد استدعائه Sub LoopExample() Dim Cell As Range Call YK_Start Columns("B:F").ClearContents For Each Cell In Range("A1:A100000") Cell.Offset(, 1) = Cell.Value + 1 Cell.Offset(, 2) = Cell.Value + 2 Cell.Offset(, 3) = Cell.Value + 3 Cell.Offset(, 4) = Cell.Value + 4 Cell.Offset(, 5) = Cell.Value + 5 Next Cell Call YK_End End Sub وممكن نستغنى عن الكلمة Call ونكتب اسم الإجراء بشكل مباشر ، بس أنا تقليدي وأحب الالتزام بالتقاليد وأحبذ استخدام كلمة Call وضعت لكم بالملف المرفق كود آخر هو الذي سيتم تنفيذه من خلال ورقة العمل ، يقوم الكود بحساب الوقت المنقضي نفذ الكود ستجد أن الكود يستغرق حوالي 10 ثواني لحظة انتظر من فضلك لا تغلق الملف .. جرب التجربة الثانية .. ضع تعليق من خلال علامة ' (حرف الطاء وإنت بتكتب إنجليزي) ضع هذه العلامة في بداية السطر 'Call YK_Start عند وضع تعليق لا يتم الالتفات إلى هذا السطر أثناء التنفيذ وضع تعليق أيضاً على السطر الخاص بكود النهاية 'Call YK_End ثم نفذ الكود ..ستجد أن الوقت المستغرق حوالي 18 ثانية (يعني أن هناك حوالي - وحوالي جمع حولية والحولية هي النعجة - أعتذر للخروج ، بس مش مشكلة تستفيدوا معلومة في العربي عشان لو طلعتوا مش فاهمين الموضوع يبقا خرجتوا بمعلومة ) ستجد أن الفرق في الوقت 8 ثواني .. يلا الحمد لله وفرنا عليكم 8 ثواني ، وإنتو أكيد عارفين قيمة الثانية وفي النهاية أرجو أن يكون الموضوع مفيد ، وأن تستفيدوا منه ، ولا تنسونا بصالح دعائكم كان معكم أخوكم الموفر للثواني ياسر خليل أبو البراء دمتم بود وتقبلوا تحياتي YK_Start & YK_End.rar YK_Start & YK_End 2003.rar

الأخ الكريم يرجى تغيير اسم الظهور للغة العربية إليك الملف التالي ..طبعاً ملفك محمي بكلمة سر وحضرتك لم تذكر كلمة السر وكان باستطاعتي كسر حمايته ، فقمت بعمل ورقة مشابهة تماماً لورقة العمل الخاصة بك ، وعملت حماية لها بكلمة السر 1 قبل عمل الحماية تمت إزالة الحماية عن الخلية F3 عن طريق كليك يمين Format Cells ثم من التبويب Protection قمت بإزالة علامة الصح من جانب الخيار Locked ، حيث أن هذه الخلية بها قائمة منسدلة للجان حتى يمكنك الاختيار منها إليك الكود مرفق معه الشرح (لا تنسانا من دعائك) Sub AllowFilterInProtectedSheet() 'يقوم الكود بالسماح بعمل فلترة للبيانات في ورقة عمل محمية '-------------------------------------------------------- 'تعريف المتغير لورقة العمل Dim WS As Worksheet 'تعيين الورقة النشطة Set WS = ActiveSheet 'بدء التعامل مع ورقة العمل النشطة With WS 'إزالة الحماية عن ورقة العمل بكلمة السر 1 ، والتي تعتبر كلمة السر لورقة العمل .Unprotect Password:=1 'إزالة الفلترة في ورقة العمل في حالة وجود فلترة للبيانات مسبقاً .AutoFilterMode = False '[F3] وشرط الفلترة هو النطاق [H] فلترة البيانات تبعاً للحقل الثامن .Range("A4:H4").AutoFilter Field:=8, Criteria1:=.Range("F3").Value 'إلغاء الفلترة في حالة أن شرط الفلترة فارغ If .AutoFilterMode And IsEmpty(.Range("F3")) Then .Range("A4:H4").AutoFilter 'إعادة الحماية بنفس كلمة السر مرة أخرى .Protect Password:=1, UserInterfaceOnly:=True End With End Sub إذا أعجبك الحل يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي Allow Filter In Protected Sheet.rar

السلام عليكم أساتذتى واخوانى بالمنتدى تناولت فى موضوعى السابق طريقة نقل بيانات من ملف مغلق الى ملف مغلق أخر بطريقة تسمى ado وهى اختصار للعبارة ActiveX Data Objects بدأ العمل بها فى مايكروسوفت 1996 تستخدم هذة الطريقة فى ترحيل ونقل البيانات بين الملفات استخدمت هذه الطريقة فى جلب البيانات الى شيت رئيسى ثم ربطت الشيت الرئيسى بشيت آخر بلينك . بعد ذلك قلت لنفسى لو عندى كود لادخال البيانات الى ملف مغلق يبقى الأمر 10/ 10 ثم بحث عن كود ووجدت واحد فى أحد المواقع الأجنبية وقمت بتعديله بطريقة لا يشعر فيها المستخدم بأن الملف ده اتفتح والتفاصيل هنا : http://www.officena.net/ib/index.php?showtopic=57798 والحمد لله تم استبدال اللينك بكود . وتركت لكم الملفات فى الرابط ده . مرة مستخدما اللينك ومرة الكود فى ادخال البيانات للملف المغلق . و اليوم أقدم لكم كيفية جلب البيانات من 3 ملفات مغلقة دفعة واحدة وبضغطة زر واحدة ومن ثم ترحيلها وادخالها الى ملف مغلق آخر دون شعور المستخدم بذلك وهذا يتم بذات الطريقة السابقة . للأصدقاء من خارج المنتدى : على الميديا فاير من خلال الرابط التالى http://www.mediafire.com/download/gidslzjdssb2jii/copy__data_from_a_closed_excel_file__&_paste_it_in_a_closed_excel_file_by_mokhtar_(__3_).rar للأصدقاء فى المنتدى : تفضلوا الملفات فى المرفق التالى . أرجوا أن يفيدكم وتستمتعوا به تحياتى للجميع copy data from 3 closed excel file & paste it in a closed excel file by mokhtar ( 3 ).rar

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

أولا أساتذتى واخوانى السلام عليكم ورحمة الله وبركاته ثانيا بارك الله فييك اخى j011 ثالثا : أشكرك أستاذى الكريم ياسر خليل على مروك الكريم وتشجيعك لى وتنفيذا لتوجيهاتك أقدم للزملاء شرحا مبسطا : بعد ما نوحد ربنا ونصلى على المصطفى صللى الله عليه وسلم الموضوع حضراتكم فيه ثلاث أفكار يمكن تطبيقها 1 - نسخ أو جلب أو ترحيل بيانات من ملف مغلق واحد 2 - نسخ أو جلب أو ترحيل بيانات من أى عدد من الملفات المغلقة . 3- - ادخال بيانات الى ملف مغلق ( بطريقة لا تشعر فيها بأنه تمت عملية نسخ الى هذا الملف تماما مثل البرامج التى تعمل فى الخلفيه دون شعور المستخدم ) 1-الكود التالى نضعه فى حدث الـــــــ Workbook بتاع الملف المغلق اللى هننقل منه البيانات Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Save Application.Quit End Sub الكود يعمل على حفظ البيانات التى كتبناها فى الملف المغلق الذى نريد النقل منه كما أنه يغلق الاكسل بدون تدخل منك . **************************************************************************************** الكودان التاليان نضع كلا منهما ا فى مديول عادى فى الملف اللى هنحط فيه البيانات التى أخذناها من الملف المغلق وهما معا أحد تطبيقات نظام ado فلى نقل البيانات الكود الأول : نضعه كما هو بدون تتغيير : Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean) Dim rsCon As Object Dim rsData As Object Dim szConnect As String Dim szSQL As String Dim lCount As Long ' Create the connection string. If Header = False Then If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=No"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=No"";" End If Else If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=Yes"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=Yes"";" End If End If If SourceSheet = "" Then ' workbook level name szSQL = "SELECT * FROM " & SourceRange$ & ";" Else ' worksheet level name or range szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" End If On Error GoTo SomethingWrong Set rsCon = CreateObject("ADODB.Connection") Set rsData = CreateObject("ADODB.Recordset") rsCon.Open szConnect rsData.Open szSQL, rsCon, 0, 1, 1 ' Check to make sure we received data and copy the data If Not rsData.EOF Then If Header = False Then TargetRange.Cells(1, 1).CopyFromRecordset rsData Else 'Add the header cell in each column if the last argument is True If UseHeaderRow Then For lCount = 0 To rsData.Fields.Count - 1 TargetRange.Cells(1, 1 + lCount).Value = _ rsData.Fields(lCount).Name Next lCount TargetRange.Cells(2, 1).CopyFromRecordset rsData Else TargetRange.Cells(1, 1).CopyFromRecordset rsData End If End If Else MsgBox "No records returned from : " & SourceFile, vbCritical End If ' Clean up our Recordset object. rsData.Close Set rsData = Nothing rsCon.Close Set rsCon = Nothing Exit Sub SomethingWrong: MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ vbExclamation, "Error" On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Array_Sort(ArrayList As Variant) As Variant Dim aCnt As Integer, bCnt As Integer Dim tempStr As String For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 For bCnt = aCnt + 1 To UBound(ArrayList) If ArrayList(aCnt) > ArrayList(bCnt) Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If Next bCnt Next aCnt Array_Sort = ArrayList End Function الكود الثانى : ده توأم السابق يتعاونان معا فى سحب البيانات من الملف المغلق لكن الكود ده هو اللى هنلعب بيه الكورة ونغير فيه بكل سهوله وأريحيه Sub GetData_Example1() ' السطر الاول بنقول للكود هات البيانات من الملف المغلق الفلانى/ الشيت الفلانى ' السطر الذى يليه بنقول للكود انسخ المدى الفلانى من الشيت الفلانى 'وكمان الصق الكلام ده فى الخليه الفلانيه GetData ThisWorkbook.Path & "\mokhtar1.xls", "Sheet1", _ "A1:C5", Sheets("Sheet1").Range("AA1"), True, True ActiveWorkbook.Save Application.Quit End Sub ملحوظة مهمه فى الكود السابق :بص كده على الكلمتين دول True, True الكلمة الاخيرة تخلى الكود يظهر راس الصفحة ( لاحظ ذلك فى مرفق الموضوع ) أما لوكتبناهم بالشكل ده True, false رأس الصفحة مش هييجى ضمن البيانات التى أخدناها من الملف المغلق ايضا لاحظ هنا أننا بنا خد البيانات بتاعتنا من ملف اكسل مغلق واحد وبكده نكون خلصنا الفكرة الأولى . بعد ما خلصت الفكرة الاولى اخوانى شعرت بأنه لو يمكن ادخال البيانات الى ملف مغلق تبقى العمليه ايه !!!!!!!! ومن هنا ظهرت الفكرة الثانية الفكرة الثانيه : هى ادخال بيانات الى ملف مغلق طبعا ليس من المعقول ادخال البيانات الى ملف مغلق دون فتحه لذلك بحثت مرارا وتكرارا عن كود يفتح الملف المغلق وجربت أكتر من كود لحد ما عثرت على واحد سهل وحسيت منه أننى أستطيع تعديله وبالفعل تم الامر لى بعون الله وتوفيقه انظر الى الموضوع التالى : http://www.officena.net/ib/index.php?showtopic=57798 الكود ده غيرت فيه بحيت يفتح الملف ووتدخل البيانات بسرعة من غير ما حد يحس ان فيه حاجه حصلت وهذا هو الكود Sub export_data() Dim mokhtar2 As Workbook Dim mokhtar3 As Workbook Application.ScreenUpdating = False Set mokhtar2 = ActiveWorkbook Set mokhtar3 = Workbooks.Open("C:/TEMP/mokhtar3.xls") mokhtar2.Sheets(1).Range("A1:C5").Copy With mokhtar3.Sheets(1).Range("A1") .PasteSpecial xlValues .PasteSpecial xlFormats End With Application.Quit End Sub الكود السابق نضعه فى مديول عادى فى الملف اللى هنرحل منه الى الملف المغلق اللى هو فى الأصل الملف اللى بستورد اليه البيانات من الملف المغلق ( الملف الرئيسى ) الكود معناه : بنصرح للبرنامج ان مختار 2 ومختار 3 دول اعتبرهم Workbook ونشط لى مختار 2 وانسخ المدى a1 : c5 منه وطيران على المجلد temp اللى فى الــــ c هتلاقى هناك الملف المغلق مختار 3 افتحه وقله مختار 2 بيسلم عليك وباعتلك شويه البيانات دول بمناسبة المولد النبوى ورأس السنة الميلادية وقله لو سمحت يا عمو حطهم فى الخلية a1 ومتنساش تقفل الباب وراك يلا بسرعة كده ومن غير ما حد يحس بيك . وبكه نكون خلصنا من الفكرة الثانيه . ************************************************************ الفكرة الثالثه : وليدة الفكرة الأولى الا انها تقوم على النسخ من عدد غير محدود من الملفات المغلقه ( 2 3 4 5 6 7 ........) بعكس الفكرة الأولى التى ننسخ فيها بيانات من ملف مغلق واحد فقط والكود التالى يمثل النقل من 3 ملفات مغلقة mokhtar1 mokhtar2 mokhtar3 Option Explicit Sub GetData_Example3() 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 1 ' True, True لاحظ فيهما الكلمتين GetData ThisWorkbook.Path & "\mokhtar1.xls", "Sheet1", _ "A1:C12", Sheets("Sheet1").Range("A1"), True, True 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 2 GetData ThisWorkbook.Path & "\mokhtar2.xls", "Sheet1", _ "a2:c11", Sheets("Sheet1").Range("A13"), True, True 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 3 GetData ThisWorkbook.Path & "\mokhtar3.xls", "Sheet1", _ "E1:E23", Sheets("Sheet1").Range("E1"), True, True 'وبنفس الكيفية يمكنك زيادة عدد الملفات المغلقة End Sub ' وسلام الله عليكم ورحمته وبركاته .

الأخ الحبيب عادل أبو زيد إليك في المرفق الملفين معاً.. ملف خاص بكل أوراق العمل .. وملف خاص بورقتي عمل .. عندك اللي يعجبك اتفضله Distinct Names From Multi Sheets.rar

وعليكم السلام تفضل يابو عبدالله DATe CH.rar