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

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

السلام عليكم جرب هذا Sub Macro1() Dim wo1 As Workbook, wo2 As Workbook Dim sh As Worksheet Dim MyPath As String Dim R As Integer, RR As Integer Dim Last As Long '''''''''''''''''''' On Error GoTo 1 Application.ScreenUpdating = False '''''''''''''''''''' Set wo1 = ThisWorkbook MyPath = wo1.Path & Application.PathSeparator & "Book2.xlsm" Set wo2 = Workbooks.Open(MyPath) Set sh = wo2.Worksheets("Book2") '''''''''''''''''''' wo1.Activate With sh For R = 1 To 35 If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1 .Cells(Last, "A").Value = Range("D5").Value2 .Cells(Last, "A").NumberFormat = "13-00000" .Cells(Last, "B").Value = Date .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value RR = RR + 1 End If Next End With ''''''''''''''''''''' If RR Then Range("D5").Value2 = Val(Range("D5")) + 1 Range("B8:G42").ClearContents End If '''''''''''''''''''' 1: wo2.Close True Application.ScreenUpdating = True If Err Then MsgBox Err.Number Set wo1 = Nothing Set wo2 = Nothing Set sh = Nothing End Sub تحياتي

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

رتب أسمائك أبجديا بمنتهى البساطة وبعيدا عن تعقيد الكود رتب أسمائك أبجديا بالمعادلات.rar

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

بسم الله الرحمن الرحيم لِلَّهِ مُلْكُ السَّمَاوَاتِ وَالْأَرْضِ يَخْلُقُ مَا يَشَاء يَهَبُ لِمَنْ يَشَاء إِنَاثًا وَيَهَبُ لِمَن يَشَاء الذُّكُورَ أَوْ يُزَوِّجُهُمْ ذُكْرَانًا وَإِنَاثًا وَيَجْعَلُ مَن يَشَاء عَقِيمًا إِنَّهُ عَلِيمٌ قَدِيرٌ صدق الله العظيم يشرفنى أن أزف لكم بشرى ساره على قلبى لآخى وحبيب قلبى الاستاذ / أحمد فضيله بقدوم مولوده الاول يوسف أحمد فضيله بارك الله فيه وجعله الله عونا وسندا لابيه اللهم إجعله قرة عين لآبيه وأمه وإجعله ياربنا من حملة كتابك العزيز إنه ولى ذلك والقادرعليه

إخوانى الأعزاء السلام عليكم ورحمة الله وبركاته هذا الكود يحسب عدد الخلايا الملونة بلون معين يتم تحديد اللون عن طريق تحديد الخلية التى تحتوى على اللون المطلوب ثم يتم تحديد المدى المراد حساب عدد الخلايا الملونة فيه Sub ragab_counter() Dim rng As Range Dim rng2 As Range On Error Resume Next 1: Set rng = Application.InputBox("اختر بالماوس الخلية التى تحتوى على اللون المطلوب", "اختيار اللون", , , , , , 8) If rng Is Nothing Then MsgBox ("من فضلك اختر خلية واحدة"): GoTo 1 If rng.Cells.Count > 1 Then MsgBox ("من فضلك اختر خلية واحدة"): GoTo 1 End If color_index = rng.Interior.ColorIndex If color_index = -4142 Then MsgBox ("هذه الخلية غير ملونة من فضلك اختر خلية أخرى"): GoTo 1 2: Set rng2 = Application.InputBox("حدد بالماوس المدى المطلوب", "تحديد المدى", , , , , , 8) If rng2 Is Nothing Then MsgBox ("من فضلك حدد المدى المطلوب"): GoTo 2 For Each cl In rng2 If cl.Interior.ColorIndex = color_index Then color_count = color_count + 1 End If Next MsgBox "عدد الخلايا الملونة بهذا اللون يساوى " & " " & color_count, , "عدد الخلايا الملونة" End Sub عد الخلايا الملونة.rar

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

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

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

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

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

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

الف مبروك استاذ احمد ( ابو يوسف ) . اللهم إجعله قرة عين لآبيه وأمه وإجعله ياالله من حملة كتابك العزيز .

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

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

الأخ / ابو يوسف الف الف مبروك جعله الله من عباده الصالحين ونفع به الاسلام والمسلمين --------------- والشكر للأخ سعيد بيرم ، على طرح الموضوع

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

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

وهذه دالة معرفة Function count_color(rng As Range) For Each cl In rng If cl.Interior.ColorIndex = 6 Then R = R + 1 End If Next count_color = R End Function وتستخدم كالآتى =count_color(D1:E100) عد الخلايا المظللة2.rar

السلام عليكم شاهد هذا الرابط ان شاء الله يفي بالغرض http://www.officena.net/ib/index.php?showtopic=40658&hl=

تفضل أخى Sub count() Application.ScreenUpdating = False For Each cl In Range("D:E") If cl.Interior.ColorIndex = 6 Then R = R + 1 End If Next Range("H2") = R Application.ScreenUpdating = True End Sub عد الخلايا المظللة1.rar

وهذا هو بعد التضبيط وبه الكود التالي (لابد من تخفيض أمان الماكرو) Sub Macro1() old_N = Format([M1], "dd-mm-yyyy") ActiveSheet.Name = old_N new_N = Format([M1] + 1, "dd-mm-yyyy") ActiveSheet.Copy After:=Sheets(Sheets.Count) With Sheets(old_N) [M1] = .[M1] + 1 .Protect End With ActiveSheet.Name = new_N [F9999].End(xlUp).Copy [F1].End(xlDown).End(xlDown).Select Selection.PasteSpecial Paste:=xlPasteValues Range("B2:I" & [A9999].End(xlUp).Row).ClearContents [C9999].End(xlUp).End(xlUp).Offset(0, 4).Select Cells([C9999].End(xlUp).End(xlUp).Row, "G").Select Range([F9999].End(xlUp).Offset(-1, 0), Selection).ClearContents End Sub تفضل المرفق (تم دمج الموضوعين) مطلوب التعديل3.rar

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

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

الف مبروك استاذ احمد ( ابو يوسف ) . اللهم إجعله قرة عين لآبيه وأمه وإجعله ياالله من حملة كتابك العزيز .

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

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

الف مبروك ويتربى في عزك أن شاء الله

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

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

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

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

بارك الله فيك

هل فكرت أخى بحساب عمرك كم سنة ؟ كم يوم ؟ ممكن لكن كم ساعة ؟ كم ثانية ؟ إحسبها معى هناك بعض المعادلات ستجدها لاتعمل وذلك لأنها تعمل على 2007 المرفق الثانى معرب البيانات أحسب عمرك باليوم والساعة والثانية.rar أحسب عمرك باليوم والساعة والثانية.rar

اخوي تفضل تم التعديل واعتذر عن التأخير بسبب المشاغل Database8.rar

السلام عليكم ترتيب المراكز العشر الاوائل حسب المجموع والعمر ادخل معطياتك بداية الكود '================================================== ' من نطاق البيانات '================================================== '''''''' اسم النطاق او عنوانه مع اسم الورقة Private Const MyRng As String = "RangDate" '''''''' ارقام الاعمدة من نطاق البيانات '''''''' :حسب الترتيب التالي '''''''' رقم الجلوس,الاسم,تاريخ الميلاد,الفصل '''''''' SeatNum,Name,Bridate,MyClass Private Const MyColumn As String = "1,2,4,3" '================================================== ' من ورقة الاوائل '================================================== '''''''' اول خلية لوضع لست الاوائل Private Const MyRngPast As String = "C7" '''''''' (نطاق الاعدادات (اسماء الفصول والمواد Private Const kh_Stg As String = "MySeting" '''''''' تنسيق التاريخ Private Const DateFormat As String = "yyyy/mm/dd" '================================================== '================================================== وايضا في النطاق المسمى MySeting في ورقة الاوائل اعمل تنسيقاتك في الصف الاول من جدول الاوائل وهي تنسخ اتوماتيكيا الى باقي الصفوف مع العلم ان التسلسل ايضا تلقائي المرفق اكسل 2003-2010 ترتيب المراكز العشر الاوائل حسب المجموع والعمر.rar ======================================= هذا المرفق مع بعض التحسينات وجلب المادة المختارة والفصل المختار في الخلايا الاعلى للجدول ترتيب المراكز العشر الاوائل حسب المجموع والعمر.rar ================================================ السلام عليكم جعلت مخرجات الكود يالنسبة للمادة والفصل في الخلايا K2:K3 يعني خارجة عن نطاق الطباعة علشان الواحد يعمل عناوين الجدول حسب مايريد انا عملت معادلة حسب طلبك ممكن تحولها في اي موضع تريده المرفق 2003 ترتيب المراكز العشر الاوائل حسب المجموع والعمر1.rar ============================================== تفضل المرفق 2003 ترتيب العشرة الاوائل حسب المجموع والعمر2.rar