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

أخى محمد جرب الكود التالى Sub ragab() Dim cl As Range, LR As Integer Dim sh As Worksheet, R_N As Integer Set sh = ورقة3 '=========================================== Application.ScreenUpdating = False x = [G13] LR = sh.[G1000].End(xlUp).Row + 1 Range("A13:K13").Copy For Each cl In sh.Range("G13:G" & LR) If cl = x Then R_N = cl.Row sh.Cells(R_N, 1).PasteSpecial xlPasteValues GoTo 1 End If Next sh.Cells(LR, 1).PasteSpecial xlPasteValues 1: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ترحيل.rar ترحيل.rar

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

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

برنامج تسجيل التحاليل الطبية ************************ برنامج مجانى لكل مريض و لكل طبيب يعالج مرضاه بالمجان ************************************************* رابط شرح البرنامج https://www.youtube.com/watch?v=szAFJNL2CEU&feature=youtu.be ************************************************ رابط تحميل Microsoft Access 2010 Runtime https://www.microsoft.com/en-us/download/details.aspx?id=10910 ****************************************************** رابط تحميل برنامج تسجيل التحاليل الطبية http://www.mediafire.com/download/yf7bh9mmiy3f8hr/%D8%AA%D8%B3%D8%AC%D9%8A%D9%84+%D8%A7%D9%84%D8%AA%D8%AD%D8%A7%D9%84%D9%8A%D9%84+++.accdb ****************************************************** اسم المستخدم : الحمد لله كلمة السر : الحمد لله برنامج تسجيل التحاليل الطبية ************************ برنامج مجانى لكل مريض و لكل طبيب يعالج مرضاه بالمجان ************************************************* رابط شرح البرنامج https://www.youtube.com/watch?v=szAFJNL2CEU&feature=youtu.be ************************************************ رابط تحميل Microsoft Access 2010 Runtime https://www.microsoft.com/en-us/download/details.aspx?id=10910 ****************************************************** رابط تحميل برنامج تسجيل التحاليل الطبية http://www.mediafire.com/download/yf7bh9mmiy3f8hr/%D8%AA%D8%B3%D8%AC%D9%8A%D9%84+%D8%A7%D9%84%D8%AA%D8%AD%D8%A7%D9%84%D9%8A%D9%84+++.accdb ****************************************************** اسم المستخدم : الحمد لله كلمة السر : الحمد لله

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

ونعم المعلم والمتابع أجمل تحياتى واحترامى للأستاذ ياسر خليل

أخي الحبيب ياسر العربي الفكرة مش ف الفك أنا عندي بدل الطريقة الواحدة عشر طرق ...بس نحب نستفيد من الجديد وبصراحة ملفك عجبني وإن شاء الله يظبط معاك أما بالنسبة لـ 32 بت ..فيبدو أنني قد هجرته تماماً ولم أعد أعمل عليه .. اللي خد ع الشغل العالي صعب يرجع تاني للشغل الضعيف أنا بالفعل مرتاح جداً في نسخة الـ 64 بت ويندوز 10 وأوفيس 2013 نسخة 64 بت وتعمل بكفاءة عالية تقبل تحياتي يا كبير

حبيبي الغالي ابو البراء رجع للعادة بتاعته تاني ماشي ياريس موضوع فك محرر الاكواد للامتدادت الاخرى تحت البحث طبعا وانت عارف الموضوع دا ان لسه بنبحث فيه يبقي كدا وقع النقطة الاولي النقطة التانية مجرب على معظم الامتدادات وفك الاوراق بدون مشاكل اما عندك مش شغال مش عارف ليه انا هنزل نسخة مخصوص 64 عشان خطرك بس لما النت يظبط معايا هحملها اتعب نفسك كدا وجربها على نسخة 32 كدا وبعدين اللي عاوز يفك ملف لو هخليه يحوله لمقطع صوتي هيحوله تقبل تحياتي وجاري ارفاق فيديو لطريقة عمل البرنامج فيديو طريقة العمل yasser vba.rar

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

وتكون النتيجة كما بالملف المرفق spin.rar

بعد اذن أخى الفاضل سليم ولاثراء الموضوع جرب أخى هذا الكود Sub ragab() Dim LR As Integer, LR1 As Integer, i As Integer, x As Integer Dim sh As Worksheet, cl As Range, TT As Integer, DD As Integer Set sh = Sheet1 '=================================================================== On Error Resume Next If IsEmpty(Range("C1")) Or Not IsNumeric(Range("C1")) Then Exit Sub TT = [C1] Range("A4:D1000").ClearContents LR = sh.Range("B1000").End(xlUp).Row - 1 DD = LR - Application.WorksheetFunction.CountIf(sh.Range("E2:E" & LR + 1), "ok") If DD = 0 Then MsgBox ("لا يوجد أسماء متاحة للاختيار منها") Exit Sub End If MsgBox ("عدد الأسماء المتاح الإختيار منها " & " " & DD) If TT > DD Then Exit Sub 1: x = Int(Rnd(1) * LR + 1) LR1 = Range("A1000").End(xlUp).Row '=================================================================== If sh.Cells(x + 1, 5) = "ok" Then GoTo 1 For Each cl In Range("A4:A" & LR1) If cl = x - 1 Then GoTo 1 Exit For End If Next '=================================================================== For i = 1 To 4 Cells(LR1 + 1, i) = sh.Cells(x + 1, i) Next sh.Cells(x + 1, 5) = "ok" R = R + 1 If R = TT Then Exit Sub GoTo 1 End Sub اسماء السائقين ومكان عملهم1.rar

عسى ان يكون المطلوب اسماء السائقين ومكان عملهم salim.rar

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

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

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

أخي الكريم أبو هايدي ضع الأسطر التالية لتؤدي الغرض إن شاء الله Private Sub TextBox2_Change() If TextBox2 <> "" And TextBox3 <> "" Then TextBox4.Value = Val(TextBox2) / Val(TextBox3) Else TextBox4.Value = "" End Sub Private Sub TextBox3_Change() If TextBox2 <> "" And TextBox3 <> "" Then TextBox4.Value = Val(TextBox2) / Val(TextBox3) Else TextBox4.Value = "" End Sub

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والادكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود ترحيل أعمدة معينة في هذا الكود سيتم ترحيل الأعمدة الموجودة في الصفحة المصدر ( الشيت ) ويمكن تغييرها الى أي أعمدة تبغاها ("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1"). طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ''' هذا الكود للعالم العلامة / عبد الله باقشير Sub KH_START1() Dim R As Integer, M As Integer, N As Integer Sheets("كشف ناجح").Range("B7:Es1000").ClearContents Sheets("كشف الدور الثاني").Range("B7:Es1000").ClearContents ''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات M = 6: N = 6: S = 6 Application.ScreenUpdating = False ''' بداية ونهاية صفوف الورقة المصدر For R = 11 To 700 ''' رقم عمود المعيار وكلمة المعيار If Cells(R, 113) = "ناجح" Then M = M + 1 ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy ''' سيتم اللصق في هذا الشيت With Sheets("كشف ناجح") ''' سيتم اللصق بدءا من عمود .Range("B" & M).PasteSpecial xlPasteValues .Range("B" & M).PasteSpecial xlPasteFormats .Range("B" & M) = M - 6 End With Application.CutCopyMode = False ''' للصفحة الأخرى المطلوب الترحيل إليها 'رقم عمود المعيار وكلمة المعيار ElseIf Cells(R, 113) = "دور ثان في" Then ''' لترك صف اعلا كل صف N = N + 2 ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy ''' سيتم اللصق في هذا الشيت With Sheets("كشف الدور الثاني") .Range("B" & N).PasteSpecial xlPasteValues .Range("B" & N).PasteSpecial xlPasteFormats .Range("B" & N) = (N - 6) / 2 End With Application.CutCopyMode = False End If Next MsgBox "تم ترحيل " & M - 6 & " طالب ناجح" & Chr(10) & Chr(10) & _ "تم ترحيل " & (N - 6) / 2 & " طالب دور ثاني", vbMsgBoxRight, "الحمدلله" Application.ScreenUpdating = True End Sub ودمتم في حفظ الله ترحيل مفيد باختبار اعمدة معينة.rar

السلام عليكم دالة استخراج تاريخ الميلاد او النوع او المحافظة من الرقم القومي ثلاثة معطيات بدالة واحدة Option Explicit ' بسم الله الرحمن الرحيم ' ******************** ' دالـــــــــــــــة ' Kh_Date_Sex_Province ' ( استخراج تاريخ الميلاد او النوع (ذكر - انثى ' او المحافظة من الرقم القومي '============================================== ' MyTest ' اذا كانت = 1 تقوم باستخراج تاريخ الميلاد ' اذا كانت = 2 تقوم باستخراج النوع ' اذا كانت = 3 تقوم باستخراج المحافظة '---------------------------------------------- ' MyProvinces في متغير الجدول ' العمل لم يستكمل بعد ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ ' بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة ' : مثال على ذلك ' "01/القاهرة" '============================================== '----------------------------------------------------------------- Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte) Dim MyProvinces As Variant Dim r As Integer Dim yy As String Dim ty As String * 1 Dim d As String * 2, m As String * 2, y As String * 2 _ , x As String * 2, xx As String * 2 '============================================== ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _ , "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _ , "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _ , "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح") '============================================== Kh_Date_Sex_Province = "" On Error GoTo 1 If Len(Trim(MyNumber)) = 0 Then GoTo 1 End If If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then Kh_Date_Sex_Province = "Error_MyNumber" GoTo 1 End If If MyTest = 1 Then d = Mid(MyNumber, 6, 2) m = Mid(MyNumber, 4, 2) y = Mid(MyNumber, 2, 2) ty = Left(MyNumber, 1) Select Case ty Case "2": yy = y Case "3": yy = "20" & y Case Else: yy = "" End Select If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d) ElseIf MyTest = 2 Then If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _ yy = "ذكر" Else yy = "انثى" Kh_Date_Sex_Province = yy ElseIf MyTest = 3 Then x = Mid(MyNumber, 8, 2) For r = LBound(MyProvinces) To UBound(MyProvinces) xx = MyProvinces(r) If x = xx Then Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3) Exit For End If Next End If 1: End Function بالنسبة لمعطيات المحافظات لم تستكمل بعد ويمكنك اضافة المحافظات المتبقية حسب ما شرحت بالكود خبور خير دالة استخلاص تاريخ الميلاد و النوع و المحافظة من الرقم القومي.rar

بسم الله الرحمن الرحيم بسم الله و الحمدلله و الصلاة و السلام على اشرف خلق الله سيدنا محمد و على آله و صحبة و من والاه أما بعد نظرا لكثرة السؤال عن فك الحماية اما لمحرر الاكواد او لورق العمل قمت بدمج الاكواد مع بعض التعديلات في ملف واحد للتسهيل على الاخوة فقط كل ما عليك هو ان تقر ان الملف خاص بك ولا يعد تعديا علي ملفات الغير يتم تفعيل الازرار الخاصة بكسر حماية محرر الاكواد واوراق العمل كسر حماية اوراق العمل يتم فكها جميعا كل ما عليك هو اختيار الملف والموافقه على بدأ الفك وانتظر حتى يكتمل فك الاوراق جميعا طبعا وقت الفك حسب مدى صعوبة كلمة المرور اما كسر محرر الاكود ما عليك الا ان تقوم باختيار الملف الهدف-xls- فتظهر لك رسالة خطأ بعدها يتم فتح محرر الاكواد ومنها تقوم باعادة تعيين كلمة اخرى والحفظ والسلام عليكم Hack VBA.rar

اتفضل اخى الفاضل دى فى الفاير وهتلاقيها فى جوجل كروم برضه ان شاء الله بالتوفيق

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

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

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

جزاك الله خيرا أخى الحبيب على هذا التشجيع

بعد اذن أخى الحبيب ياسر ربما هذا ما يقصده أخونا محمد ايصالي1.rar

جرب الملف المرفق التالي report.rar

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

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

بعد اذن الأستاذ الفاضل / ياسر العربى ولاثراء الموضوع بناءا على فكرة أخى الفاضل أحمد الفلاحجى مارأيكم بهذه الفكرة Private Sub Worksheet_SelectionChange(ByVal Target As Range) x = Application.WorksheetFunction.CountA(Range("A:A")) + 2 If Not Intersect(Target, Range("A:A")) Is Nothing Then Sheet1.Unprotect "123" ActiveSheet.ListObjects("Table1").Resize Range("$A$2:$N" & x) Range("$A$2:$N" & x).Locked = False End If Sheet1.Protect "123" End Sub TABLE WITH PROTECT 1.rar

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

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

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

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

أخي الحبيب سعيد المفروض الحاجات الصغيرة دي منتكلمش فيها الفكرة ببساطة إني بعتمد زي ما قلت لك على إخفاء الصفوف .. ونسخ الظاهر فقط من الخلايا.. وطالما أنك تريد إخفاء العمود J يبقا الموضوع أبسط مما تتخيل في بداية الكود نظهر العمود J وننسخ ونرحل المطلوب وفي الآخر نخفيه شفت بسيطة إزاي : شالو كلب مقطقط حطوا قطة مكلبة إليك الكود بعد التعديل البسيط Sub TarhilModified() Dim Ws As Worksheet, Sh As Worksheet, LR As Long Set Ws = Sheet4: Set Sh = Sheet5 Application.ScreenUpdating = False Application.Calculation = xlManual LR = Sh.Cells(Rows.Count, "L").End(xlUp).Row + 1 With Ws .Columns("D:J").Hidden = False .Range("C8:C" & .Cells(Rows.Count, "C").End(xlUp).Row + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True .Range("C8:C" & .Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Sh.Range("L" & LR).PasteSpecial xlPasteValues .Range("I8:J" & .Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Sh.Range("M" & LR).PasteSpecial xlPasteValues .Cells.EntireRow.Hidden = False Sh.Range("I" & LR).Resize(1, 3).Value = Array(Ws.Range("M4").Value, Ws.Range("M2").Value, Ws.Range("B4").Value) .Columns("D:H").Hidden = True: .Columns("J:J").Hidden = True Sh.Activate End With Application.CutCopyMode = False Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub تقبل تحياتي

أخى الكريم // نؤكد عليكم الإلتزام بتعليمات المنتدى وبداخل المنتدى العديد والعديد من الملفات التى تشمل طلبك وطبعا نظرا لعدم تحديد شرط التنبيه اليكم بالمرفقات ملف بالمعادلات يعمل على ( 3 شروط ) ( 90 يوم ، 60 يوم ، 30 يوم ) يعمل بالتاريخين الهجرى والميلادى وبداخل الملف شرح لكيفية التعامل وتقبل منى وافر الاحترام والتقدير تنبيه.rar

و عليكم السلام و رحمة الله و بركاته ... أو سمي مربع النص المحدد أعلاه باسم مثل " ddd " اذا ddd = كذا افعل كذا ...

اخي ابو سيما ... كود الاستاذ جعفر يعمل عندي بدون مشاكل ...

عمود تاريخ الإرسال فارغ في معظم الصفوف ..كيف تريد التعامل مع الخلايا الفارغة في هذه الحالة؟

جرب تشيل كلمة Large الموجودة بعد كلمة Count .. وخلي كلمة Count بس (ممكن بسبب نسخة الأوفيس القديمة لديك والتي ما زلت متمسكاً بها)

لابد وأن لديك في موديول آخر إجراء فرعي بنفس الاسم ... قم بدمج الأسطر في كلا الكودين معاً لأن الإجراء خاص بالتنفيذ عند فتح المصنف

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

أخي الكريم مهند الدالة ISREF ترجع القيمة True في حالة أن ورقة العمل موجودة وتعطي القيمة False إذا لم تكن موجودة والخلية A1 هي أول مرجع في ورقة العمل المراد التأكد من وجودها أو عدم وجودها مثال لتفهم عمل الدالة : قم بإنشاء مصنف جديد وتأكد من وجود ورقة العمل Sheet1 بها وجرب الكود التالي Sub CheckSheetExistence() MsgBox Evaluate("ISREF(Sheet1!A1)") MsgBox Evaluate("ISREF(Data!A1)") End Sub النتائج ستكون للسطر الأول True لأن الورقة موجودة والسطر الثاني False لأن ورقة العمل Data غير موجودة ... بالتالي لو رجعنا للكود الأصلي سنجد أننا استخدمنا كلمة Not لعكس النتيجة ..بمعنى أن السطر في الكود الأصلي يفحص ويتأكد من عدم وجودة ورقة العمل فإذا لم (لاحظ لم Not) موجودة يتم تنفيذ باقي الأسطر ..أو بمعنى آخر : لو الورقة مش موجودة هتكون نتيجة الدالة False ووضعنا Not قبلها فيتم تحويل القيمة من False إلى True ، بالتالي طالما أن القيمة ستكون True يتم تنفيذ الأسطر التالية ...

اخى الحبيب الاستاذ الفاضل سعيد بيرم السلام عليكم ورحمة الله وبركاته أما عن الدعاء فإنني أسأل الله ربي وربكم أن يغير حالنا جميعا إلى أحسن حال وأن يجعلنا جميعا هداة مهديين لا ضالين ولا مضلين وأن يجعلنا جميعا ممن يقال لهم يوم القيامة : " ادخلوها بسلام ءامنين " آمين .أما عن اﻹجابة فقد تكفل الله بها بلحظة الدعاء " ادعوني أستجب لكم " وآية:" { أَمَّن يُجِيبُ الْمُضْطَرَّ إِذَا دَعَاهُ وَيَكْشِفُ السُّوءَ وَيَجْعَلُكُمْ خُلَفَاء الْأَرْضِ أَإِلَهٌ مَّعَ اللَّهِ قَلِيلًا مَّا تَذَكَّرُونَ } ضمن الله تعالى إجابة المضطر إذا دعاه، وأخبر بذلك عن نفسه؛ والسبب في ذلك أن الالتجاء إليه سبحانه ينشأ عن الإخلاص، وقطع القلب عما سواه. وللإخلاص عنده سبحانه موقع وذمة، وُجِدَ من مؤمن أو كافر، طائع أو فاجر؛ كما قال ‏{حتى إذا كنتم في الفلك وجرين بهم بريح طيبة وفرحوا بها جاءتها ريح عاصف وجاءهم الموج من كل مكان وظنوا أنهم أحيط بهم دعوا الله مخلصين له الدين لئن أنجيتنا من هذه لنكونن من الشاكرين‏} وقوله ‏{‏فلما نجاهم إلى البر إذا هم يشركون‏}‏ فأجابهم عند ضرورتهم ووقوع إخلاصهم، مع علمه أنهم يعودون إلى شركهم وكفرهم‏.‏ وفي الحديث‏:‏ ‏(‏ثلاث دعوات مستجابات لا شك فيهن دعوة المظلوم ودعوة المسافر ودعوة الوالد على ولده)‏ ذكره صاحب الشهاب؛ وهو حديث صحيح‏.‏ فيجيب المظلوم لموضع إخلاصه بضرورته بمقتضى كرمه، وإجابة لإخلاصه وإن كان كافرا، وكذلك إن كان فاجرا في دينه؛ ففجور الفاجر وكفر الكافر لا يعود منه نقص ولا وهن على مملكة سيده، فلا يمنعه ما قضى للمضطر من إجابته‏.‏ وفسر إجابة دعوة المظلوم بالنصرة على ظالمه بما شاء سبحانه من قهر له، أو اقتصاص منه، أو تسليط ظالم آخر عليه يقهره كما قال عز وجل :‏{وكذلك نولي بعض الظالمين بعضا‏} .‏ وفي هذا تحذير من الظلم جملة، لما فيه من سخط الله ومعصيته ومخالفة أمره؛ حيث قال على لسان نبيه في صحيح مسلم وغيره‏:‏ ‏(يا عبادي إني حرمت الظلم على نفسي وجعلته بينكم محرما فلا تظالموا‏.‏‏.‏‏.‏)‏ الحديث‏.‏ فالمظلوم مضطر، ويقرب منه المسافر؛ لأنه منقطع عن الأهل والوطن منفرد عن الصديق والحميم، لا يسكن قلبه إلى مسعد ولا معين لغربته‏.‏ فَتَصْدُق ضرورتُه إلى المولى، فيخلص إليه في اللجوء، وهو المجيب للمضطر إذا دعاه. وكذلك دعوة الوالد على ولده، لا تصدر منه مع ما يعلم من عطفه عليه وشفقته، إلا عند تكامل عجزه عنه، وصدق ضرورته؛ وإياسه عن بر ولده، مع وجود أذيته، فيسرع الحق إلى إجابته‏.‏ والسلام عليكم

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

أخي الكريم محمود ننتظر إرفاق ملفك ليطلع عليه إخوانك ممن يريدون تقديم المساعدة ... تقبل تحياتي

أخي الكريم يوسف عطا جرب المعادلة بهذا الشكل علها تؤدي الغرض إن شاء الله =VALUE(LEFT(LEFT(F2,FIND(" ",F2)-1),2)) تقبل تحياتي

جواب المهندس ياسر فيه الكثير من الابداع والحكمة شكرا لك وباركك الله

الأخ الحبيب أحمد مرجان نعتذر عن التأخير في تقديم المساعدة (وكل تأخيرة فيها عطلة للناس بس أكيد فيها خيرة بردو) إليك الكود التالي (وعشان غرامة التأخير مرفق شرح لكل أسطر الكود عشان تقدر تعدل بما يناسبك إن شاء الله) Sub ImportDataFromClosedWBUsingVLOOKUP() 'تعريف المتغيرات Dim WBK As Workbook Dim Rng As Range Dim LastRow As Long 'إيقاف تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إيقاف خاصية رسائل التنبيه Application.DisplayAlerts = False 'ليساوي المصنف المسمى 1 والموجود في نفس مسار المصنف الحالي [WBK] تعيين قيمة للمتغير 'يقوم هذا السطر أيضاً بفتح المصنف في المسار المذكور Set WBK = Workbooks.Open(ThisWorkbook.Path & "\1.xlsx") 'تعيين قيمة للنطاق المراد جلب البيانات منه من المصنف المسمى 1 Set Rng = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row) '[Sheet1] بدء التعامل مع المصنف الحالي في ورقة العمل With ThisWorkbook.Sheets("Sheet1") 'تحديد رقم صف آخر خلية بها بيانات في العمود الأول LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'وضع معادلة دالة البحث في العمود الثاني والحصول على النتيجة من العمود الثاني في المصنف 1 With .Range("B2").Resize(LastRow - 1) .Formula = "=IFERROR(VLOOKUP(A2," & Rng.Address(, , , True) & ",2,False),"""")" .Value = .Value End With 'وضع معادلة دالة البحث في العمود الثالث والحصول على النتيجة من العمود الثالث في المصنف 1 With .Range("C2").Resize(LastRow - 1) .Formula = "=IFERROR(VLOOKUP(A2," & Rng.Address(, , , True) & ",3,False),"""")" .Value = .Value End With End With 'إغلاق المصنف المأخوذ منه البيانات بدون حفظ WBK.Close SaveChanges:=False 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub وبكدا نكون دفعنا غرامة التأخير والحمد لله تقبل تحياتي Import Data From Closed WB Using VLOOKUP YasserKhalil.rar

طريقة عمل ( فورم ) فاتورة ووضع اكوادها وترحيل بياناتها واستدعائها وطباعتها !! خطوة خطوة السلام عليكم اساتذة المنتدي وخبراؤه الكبار الاخوة الافاضل (((( الدرس الثاني )))) مرفق ملف اكسيل به الفورم والمثال الذي سنعمل عليه في الدروس القادمة وسنتعرف في هذا الدرس علي العمليات الحسابية والتفقيط داخل فورم الفاتورة وطريقة وضع اكوادها اليكم اولا رابط تحميل مباشر للملف الفيديو ( رابط خارجي ) والتالي شرح بفيديو مباشر من خلال هذا الصرح العملاق ( ويمكنكم ايضا تحميله من هنا ) ارجو أن يوفقني الله في الشرح وان اكون عند حسن ظنكم جزاكم الله خيرا طريقة عمل فاتورة ووضع اكوادها2اكسيل .rar

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