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

بسم الله الرحمن الرحيم بلاش الشتيمة والسلام عليكم move.rar

بسم الله الرحمن الرحيم ميزه وخاصية ممتازه وهى Flash Fill Excel 2013 (تعبئة سريعة) تغنيك عن استخدام صيغ ومعادلات ..الخ . اتمنى ان تفيدكم . ولاتنسونا بصالح دعاؤكم https://www.youtube.com/watch?v=OZyrmcInZLU flash fill.rar

السلام عليكم ورحمة الله نقدم لكم كلمة مرور عن طريق توليد رقم عشوائي شرح الطريقة فتح ملف جديد وإضافة التالي 1 - فورم ونسميه Form1 2 - مربع نص ونسميه Txt1 3 - زر امر ونسميه Cmd_LogoIn وقبل ان نتطرق للفورم والكود نذهب اولا إلي الصفحة (الشيت) ونختار الخلية [IV1] تستطيع تغييرها حسب رغبتك ونضع بداخلها المعادلة التالية : =RANDBETWEEN(999999;9999999) وهي تقوم بتوليد رقم عشوائي بتكوًن بين 9,999,999 وبين 9,999,999 وتستطيع التغيير إلي الأكثر او الأقل حسب ماتراة مناسب . ثم نذهب للخلية [IV3] ونضع بها المعادلة التالية : =LEFT(IV2;3)+RIGHT(IV2;2) وهي تأخذ اول ثلاثة ارقام من يسار الرقم بالخلية [IV2] وأول رقمين من يمين الخلية المذكورة. وقيمة الخلية [IV2] يتكون عن طريق الكود في حدث تنشيط الفورم وهو يساوي قيمة الخلية التي يتم توليد الأرقام العشوائية فيها وهو [IV2] = [IV1.Value Private Sub UserForm_Activate() ' لاحظ الخلية [IV2] تساوي الخلية [IV1] وهي التي تقوم بتوليد الرقم العشوائي [IV2] = [IV1].Value 'لاحظ هنا عنوان الفورم هو الرقم العشوائي Form1.Caption = [IV2] End Sub ولاحظ ان الرقم العشوائي يظهر بعنوان الفورم وبتغيًر كل مرة يظهر فيها الفورم ولإستخراج كلمة المرور منه مثال ان الرقم العشوائي 760340 فاول ثلاثة ارقام من اليسار هي 760 وأول رقمين من اليمين 40 نجمعها (760 + 40 = 800 ) إذا كلمة المرور هي 800 . تستطيع ان تأخذ رقمين او ثلاثة ..إلخ من يسار الرقم العشوائي او رقمين او ثلاثة اواكثر من يمينه وبعد ذلك تجمع او تطرح والنتيجة في الخلية [IV3] كل ذلك يتم في في المعادلة ادناه : =LEFT(IV2;3)+RIGHT(IV2;2) وهذا الكود البسيط مع الشرح : Private Sub Cmd_LogoIn_Click() 'إذا كان مربع النص التكست ون يساوي فراغ If Txt1.Text = vbNullString Then 'إذا اخرج من الإجراء الفرعي Exit Sub 'غير ذلك إذا كان مربع النص لايساوي قيمة الخلية[IV3] ElseIf Txt1.Text <> [IV3].Value Then 'إذا رسالة توضح ان كلمة المرور غير صحيحة MsgBox "ßáãÉ ÇáãÑæÑ ÛíÑ ÕÍíÍÉ", vbCritical, "ÇáÊÃßÏ ãä ßáãÉ ÇáãÑæÑ" 'غير ذلك إذا كان مربع النص بيساوي [IV3] ElseIf Txt1.Text = [IV3].Value Then 'إذا رسالة توضيحية احسنت MsgBox "ÇÍÓäÊ" 'اجعل تطبيقات الاكسل مرئية Application.Visible = True 'إخفاء الفورم Unload Me ' End If End Sub اخيكم في الله أبو الحسن والحسين مرفق مثال شاشة دخول - تغيير الباسورد عشوائي.rar

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

هههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههههه حرام عليك والله هموت من الضحك

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

السلام عليكم ورحمة الله اخواني الأعزاء وائل الاسيوطي ومحمد حسن المحمدي أبو يوسف اسرني واسعدني مروركم العطر بارك الله فيكم وجزاكم الله خير الأخ الفاضل الأستاذ / مختار حسين الأخ وائل الاسيوطي في المرفق تم إضافة عداد لمحاولة إدخال كلمة المرور حسب نصيحة استاذنا /مختار حسين تستطيع إضافة حروف ,كلمات, ارقام، علامات وهي التي بين علامتي التنصيص قبل وبعد كلمة المرور المستخرجة من الرقم العشوائي الخلية [IV3].Text هي ناتج توليد الرقم العشوائي بالخلية [IV1].Text عن طريق [IV2].Text والتي تأخذ 3 ارقام من آخر الرقم العشوائي ورقمين من اوله للعلم والاحاطة فقط If Txt1.Text = "هنا تقدر تضع كلمة او حروف او ارقام او علامات" & [IV3].Text & "هنا تقدر تضع كلمة او حروف او ارقام او علامات" Then في الكود ادناة تضع الحروف قيل وبعد. مثال / الرقم العشوائي 760340 فاول ثلاثة ارقام من اليسار هي 760 وأول رقمين من اليمين 40 نجمعها (760 + 40 = 800 ) إذا كلمة المرور هي kh800mb . لما تكون الحروف إنجليزية تنتـــه لإدخالات الحروف كبيرة او صغيرة ادخلها حسب برمجتك لها. If Txt1.Text = "kh" & [IV3].Text & "mb" Then او تجعل الحروف قبــــــــــــــل فقط وستكون كلمة المرور كالتالي khmb800 وتنتبــــــــــــــه ان تكون KHMB800 مع دقة الملاحظة في أي فراغ في علامتي التنصيص قبل او بعد الكلمة او الحرف او غيره (" khmb" ) او ("khmb "). If Txt1.Text = "khMB" & [IV3].Text Then او تجعل الحروف بعـــــــــــــــد فقط وستكون كلمة المرور كالتالي 800khmb وتنتبــــــــــــــه ان تكون 800KHMB مع دقة الملاحظة في أي فراغ في علامتي التنصيص قبل او بعد الكلمة او الحرف او غيره (" khmb" ) او ("khmb "). مع ملاحظة الكلمة هنا هي بالحروف الكبيرة. If Txt1.Text = [IV3].Text & "KHMB" Then مرفق الملف وكلمة المرور هي بين كلمتي KH.....MB If Txt1.Text = "kh" & [IV3].Text & "mb" Then شاشة دخول - تغيير الباسورد عشوائي.rar

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

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

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

السلام عليكم الاخ الكريم المنتدى مليء بمثل هذه المواضيع فقط عليك البحث كما بين اخونا الاستاذ عبدالله هذا واحد وهذا آخر

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

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

الكود الاول يعمل بشكل صحيح الخاص بحذف الخلايا بناء على قيمة خلية بالنسبة للطلب الاول ارجو اذا كان قيمة خليه ف الصف رقم 17 يتم اخفاء كامل العمود تم الوصول الى الكود الحمد لله للافادة Sub HideShowColumn() Dim rRange As Range, rCell As Range Set rRange = Range("A17", Range("IV17").End(xlToLeft)) For Each rCell In rRange: rCell.EntireColumn.Hidden = (rCell = 0) Next rCell End Sub

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

ههههههههههههه والله محتاجين فعلا نخرج من وجع الدماغ شاويش شعبان شد شنب شاويش شعلان شدة شديدة شرمت شفته

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

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

شفت شاب شيك شايل شنطه شيك شبه شنطه شارلي شابلن بس خلاص

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

سهلت الفكره وبسطها اكتر With CommandButton1 .Left = .Left + Int((Rnd() - 2) * X) .Top = .Top + Int((Rnd() - 2) * Y) End With ههههههههههههههههه انا عاوزكم تبدعو هههههههه انا بفكر لو حد طلب حل لمشكلته ان زر الترحيل مش شغال او زر الخروج مثلا وقلت تفضل اخي الغالي الحل في المرفق ويجي يدوس زر ترحيل او خروج يجري منه هههههههه هاخد شتيمة للركب ههههههه move.rar

ههههههههههههههههههههههههههههههه يعني لازم لازم نعم

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

يلا بقى مش مشكلة يا صاحبى مقبولة منك يا حبيب قلبى

ما هو مفيش حل تانى غير نعم مفيش فايدة مش هافضل أجرى ورا لأ

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

أخي الحبيب ياسر ما شاء الله بارك الله أعتذر عن التكرار بسبب بطء الإنترنت والسلام عليكم

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

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

اخى الحبيب محمد الريفى جزاكم الله خيرا تقبل تحياتى

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

تحية طيبة اخي ياسر الف شكر على المساعدة

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

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("I4:N11")) Is Nothing Then Target = Format(Now) End Sub ضع الكود السابق فى حدث الورقة ثم احفظ الملف بصيغة XLS أو XLSM

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

السلام عليكم و رحمة الله وبركاته اخي ابو يوسف من وجهة نظر شخصية (في رأيي) ممكن نعمل المطلوب ب الأكواد في ورقة واحدة فقط على 3 خطوات خطوة 1 استخراج اسماء الأورات و وضها في قائمة منسدلة خطوة 2 استخراج اسماء المناطق التعليمية و وضعها في قائمة منسدلة خطوة 3 استخراج اسماء المدارس بدون تكرار الى الجدول و امامها عدد مرات التكرار هذه الفكره من وجهة نظري الممكنة وبكون التطبيق العملي تختار اسم الورقة ثم تختار المنطقة التعليمية ثم يظهر الجدول هذه فكرة لم اطبقها بعد

أخي الكريم ابحث في المنتدى ستجد الكثير من المشاركات في هذا المجال

انصحك ب 2010 اخي احمد ! بالتوفيق

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

أخي الكريم مهند أهلاً بك في المنتدى ونورت بين إخوانك شكل المنتدى هيقلب على تركي .. إليك الملف التالي عله يفي بالغرض .. ومتنساش تسلم لي على نور أحلى حاجة في المشاركة دي إنها المشاركة رقم 7.777 (أصلي بحب رقم سبعة) Unique Using Array Formula.rar

المشكله عندك اخي هل انت مفعل امان الماكرو منخفض ام لا ؟ اتبع الفيديو في المرفق اذا لاتعرف الطريقه لتفعيل الماكرو تفعيل الماكرو.rar

اخي الكريم ياسر خليل الفائده من استخدام الكود بالطريقه التي سردتها بالمشاركه السابقه ان لاتحمل كاهل الملف بالهيبرلينك حتى يصبح بطيئ جدا عند الفتح وان ولايوقف عند الخليه 650000 كحد اعلى للهيبرلينك فقط بل ينفذ الكود حتى يصل عند التوليف "ZZZZ" كأنه كتب عنوان على الخلايا فقط ونستخدم العنوان كهيبر لينك عند النقر عليه وبالامكان استخدام الكود لايحذف الهيبرلينك الا حين يصل الى الحد الاعلى بإضافة بسيطه هذه اضافه لااحبذها الافضل التعامل مع كل خليه كي لا يكبر حجم الملف ويصبح بطيئ هذا المرفق وبه الكود لحدث الصفحه وكود انشاء العناوين If ActiveSheet.Hyperlinks.Count >= 65530 Then For Each R In ActiveSheet.Hyperlinks If R.TextToDisplay > "" Then R.Delete: Exit For Next End If شرح كود الهايبر لنك_111.rar

جميع بيانات الملفات لشهر واحد حسب ملفاتك الحاليه ؟ اضفت في بعض الملفات اشهر وهميه بمعنى بيانات لـ 6 اشهر جرب الكود التالي حط الملفات بنفس فولدر الملف الذي به الكود Sub Ali_Tran_Fil() Dim Pth As String Dim F_il As String Dim S_Nm As String Dim My_Vlu() As Variant Dim Lr, Lrr, R, Dy, Ar, Az, Ar_O, ii, rr, pp, Cr Dim Date_M As Date Dim O_Wp As Workbook Dim ws As Worksheet Dim Sh As Worksheet Dim Mi_A As Worksheet Dim sht As Worksheet Set Mi_A = Sheets(1) De_Sht CStr(Mi_A.Name) Apc_Ali False '-------------------------------------------------------------------- Pth = ThisWorkbook.Path & "\" '' مسار الملفات بنفس مسار الملف الحالي '-------------------------------------------------------------------- F_il = Dir(Pth & "*.xlsx") '' xlsx صيغة ملفات الاكسل التي سيتم جلب بياناتها '-------------------------------------------------------------------- ReDim Preserve My_Vlu(1 To 10000, 1 To 6) '-------------------------------------------------------------------- Do While F_il <> "" If F_il <> ThisWorkbook.Name Then S_Nm = Pth & F_il Set O_Wp = Workbooks.Open(S_Nm) Set ws = O_Wp.Sheets(1) Lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row For R = 2 To Lr I = I + 1 My_Vlu(I, 1) = ws.Cells(R, 3) My_Vlu(I, 2) = ws.Cells(R, 1) My_Vlu(I, 3) = ws.Cells(R, 2) My_Vlu(I, 4) = ws.Cells(R, 6) My_Vlu(I, 5) = ws.Cells(R, 7) My_Vlu(I, 6) = Split(F_il, ".")(0) Next R O_Wp.Close False F_il = Dir End If Loop '-------------------------------------------------------------------- Mi_A.Range("A2").Resize(UBound(My_Vlu, 1), UBound(My_Vlu, 2)) = My_Vlu '-------------------------------------------------------------------- Mi_A.Sort.SortFields.Add Key:=Mi_A.Range("D2", Mi_A.Range("D2").End(xlDown)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Mi_A.Sort .SetRange Mi_A.Range("A2:F" & Mi_A.Range("A1").End(xlDown).Row) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With '-------------------------------------------------------------------- With CreateObject("scripting.dictionary") For ii = LBound(My_Vlu, 1) To UBound(My_Vlu, 1) If My_Vlu(ii, 1) <> "" Then If IsDate(My_Vlu(ii, 4)) Then Date_M = My_Vlu(ii, 4) Dy = .Item(Month(Date_M)) End If End If Next ii Ar = Split(Join(.Keys, ","), ",") End With '-------------------------------------------------------------------- For rr = LBound(Ar) To UBound(Ar) If IsError(Evaluate("'" & Ar(rr) & "'!A1")) Then Set Sh = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)) With Sh .Name = CStr(Ar(rr)) Az = Array("رقم العميل", "العدد", "الصنف", "التاريخ", "السعر", "إسم الملف") With .Range("A1") .Offset(0, 0).Resize(1, UBound(Az) + 1) = Az End With .Columns(1).ColumnWidth = 29.29 .Columns(2).ColumnWidth = 8.43 .Columns(3).ColumnWidth = 15 .Columns(4).ColumnWidth = 16.14 .Columns(5).ColumnWidth = 8.43 .Columns(6).ColumnWidth = 8.43 End With End If Next rr '-------------------------------------------------------------------- Ar_O = Mi_A.Range("A1").CurrentRegion.Value For Each sht In Sheets If Not sht.Index = 1 Then For pp = 1 To UBound(Ar_O, 1) If IsDate(Ar_O(pp, 4)) Then If Trim(Month(Ar_O(pp, 4))) = Trim(sht.Name) Then With sht Lrr = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Cells(Lrr, 1) = Ar_O(pp, 1) .Cells(Lrr, 2) = Ar_O(pp, 2) .Cells(Lrr, 3) = Ar_O(pp, 3) .Cells(Lrr, 4) = Ar_O(pp, 4) .Cells(Lrr, 5) = Ar_O(pp, 5) .Cells(Lrr, 6) = Ar_O(pp, 6) End With End If End If Next pp End If Next sht '**** Sh_S '**** '\\\\\\\\ Cr = Split(Mi_A.UsedRange.Address, "$")(4) Mi_A.Range("A2:F" & IIf(Cr = 1, 2, Cr)).ClearContents '//////// Apc_Ali True '************************************ Set O_Wp = Nothing: Set ws = Nothing Set Sh = Nothing: Set Mi_A = Nothing Set sht = Nothing: Erase My_Vlu End Sub Private Sub B_Set(Sh_N()) Dim T_m Dim I, J '---------------------------------- Apc_Ali False For I = LBound(Sh_N) To UBound(Sh_N) For J = I To UBound(Sh_N) If Sh_N(I) > Sh_N(J) Then T_m = Sh_N(I) Sh_N(I) = Sh_N(J) Sh_N(J) = T_m End If Next J Next I Apc_Ali True '---------------------------------- End Sub Private Sub Sh_S() Dim Sht_a As Worksheet Dim My_Sh() Dim I '------------------------------------------ Apc_Ali False ReDim My_Sh(ThisWorkbook.Worksheets.Count) I = LBound(My_Sh) For Each Sht_a In ThisWorkbook.Worksheets My_Sh(I) = Sht_a.Name I = I + 1 Next Sht_a '----------- B_Set My_Sh '----------- For I = LBound(My_Sh) + 1 To UBound(My_Sh) If Sheets(My_Sh(I)).Index <> 1 Then Worksheets(My_Sh(I)).Move After:=Worksheets(ThisWorkbook.Worksheets.Count) End If Next I Apc_Ali True '------------------------------------------ End Sub Public Function De_Sht(ByVal Nm_S As String) Dim Sh_D As Worksheet ''------------------------------------ For Each Sh_D In Worksheets Application.DisplayAlerts = False If Sh_D.Name <> Nm_S Then Sh_D.Delete Application.DisplayAlerts = True Next Sh_D ''------------------------------------ Set Sh_D = Nothing End Function Public Function Apc_Ali(Bll As Boolean) ''------------------------------------ With Application .Calculation = IIf(Bll, -4105, -4135) .ScreenUpdating = Bll .EnableEvents = Not Bll End With ''------------------------------------ End Function والمرفقات الملف وبه الكود new_Ali.rar

الله يشفيه ويعافيه ويقومه بالسلامه .. آمين .. ويشفي مرضانا ومرضى المسلمين اجمعين.

اللهم رب الناس أذهب البأس اشفه أنت الشافي لا شفاء إلا شفاؤك اللهم اشفه وعافه .. شفاء لا يغادر سقما

اللهم أنت الشافى المعافى إشف مرضانا ومرضى المسلمين جميعا اللهم أمين

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

السلام عليكم ورحمة الله وبركاته اخواني الاكارم تحية طيبة وبعد : الدالة Split هي المسؤلة عن تقسيم السلسلة النصية ويمكننا من خلالها ارجاع أو حذف الجزء الذي نحدده ويتم توظيفها في النماذج والتقارير داخل محرر الفيجوال على النحو التالي : name1 = Split(FullName, " ")(0) name2 = Split(FullName, " ")(1) name3 = Split(FullName, " ")(2) name4 = Split(FullName, " ")(4) - باعتبار FullName هو حقل الاسم الكامل علما انه يمكن كتابة الاسم داخل الكود بين علامتي تنصيص مزدوجتين وستقوم الدالة بارجاع الجزء المحدد - وما بين علامتي التنصيص " " الفاصلة التي على اساسها يتم تجزئة النص وهي هنا مسافة فارغة - اما الارقام (0) ، (1) ، (2) ... فهي ترمز الى مكان الجزء داخل النص الى هنا كل شيء يسير على ما يرام ولكن حين نريد استخدامها داخل الاستعلام نفاجأ بأنها لا تعمل وتظهر رسالة من الاستعلام بأن هذه الدالة غير معروفة والحل : ان نعقد بين الدالة والاستعلام صفقة عمل و تعارف ولن يتم لنا ذلك حتى نوجد للدالة مكان اقامة دائم في قاعدة البيانات الحالية وللدرس بقية : تعريف الدالة + التطبيق ان شاء الله

استاذ ابو حنين وجدت هذا الكود على النت ارجو يكون المقصود Sub ShowAllLinksInfo() 'Author: JLLatham 'Purpose: Identify which cells in which worksheets are using Linked Data 'Requirements: requires a worksheet to be added to the workbook and named LinksList 'Modified From: http://answers.microsoft.com/en-us/office/forum/office_2007-excel/workbook-links-cannot-be-updated/b8242469-ec57-e011-8dfc-68b599b31bf5?page=1&tm=1301177444768 Dim aLinks As Variant Dim i As Integer Dim Ws As Worksheet Dim anyWS As Worksheet Dim anyCell As Range Dim reportWS As Worksheet Dim nextReportRow As Long Dim shtName As String shtName = "LinksList" 'Create the result sheet if one does not already exist For Each Ws In Application.Worksheets If Ws.Name = shtName Then bWsExists = True Next Ws If bWsExists = False Then Application.DisplayAlerts = False Set Ws = ActiveWorkbook.Worksheets.Add(Type:=xlWorksheet) Ws.Name = shtName Ws.Select Ws.Move After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count) Application.DisplayAlerts = True End If 'Now start looking of linked data cells Set reportWS = ThisWorkbook.Worksheets(shtName) reportWS.Cells.Clear reportWS.Range("A1") = "Worksheet" reportWS.Range("B1") = "Cell" reportWS.Range("C1") = "Formula" aLinks = ActiveWorkbook.LinkSources(xlExcelLinks) If Not IsEmpty(aLinks) Then 'there are links somewhere in the workbook For Each anyWS In ThisWorkbook.Worksheets If anyWS.Name <> reportWS.Name Then For Each anyCell In anyWS.UsedRange If anyCell.HasFormula Then If InStr(anyCell.formula, "[") > 0 Then nextReportRow = reportWS.Range("A" & Rows.Count).End(xlUp).Row + 1 reportWS.Range("A" & nextReportRow) = anyWS.Name reportWS.Range("B" & nextReportRow) = anyCell.Address reportWS.Range("C" & nextReportRow) = "'" & anyCell.formula End If End If Next ' end anyCell loop End If Next ' end anyWS loop Else MsgBox "No links to Excel worksheets detected." End If 'housekeeping Set reportWS = Nothing Set Ws = Nothing End Sub