الحسامي

السلام عليكم حسب فهمي لطلبك مرفق ملف وفيه كبسة لعمل الخيارات المطلوبة اتمنى ان يلبي طلبك choice.rar

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

السلام عليكم احبائي ايه يا عم ياسر العزومة لناس وناس بس على العموم ملحوقة ----------------- وبعد اذن اخي رجب هنا كود اخر لاثراء الموضوع Dim SH As Worksheet Dim rng As Range, cell As Range Set rng = Range([E2], Cells([E10000].End(xlUp).Row, "E")) For Each cell In rng Set SH = Sheets(3) If cell.Value > 19 Then Set SH = Sheets(2) LR = SH.[B10000].End(xlUp).Row + 1 SH.Cells(LR, "B").Resize(1, 7).Value = cell.Offset(0, -3).Resize(1, 7).Value Next cell Range("B2:H" & [B10000].End(xlUp).Row).ClearContents

والله مجهود خرافي وافكار جميله ويدل على المستوى العالي الذي تتمتع به بارك الله فيك

لا اصدق ما اراه هل هناك ما زال يستخدم نسخة 2003 النسخة الامثل للاستخدام 2010 بالرغم من الاضافات الخيالية لنسخة 2013 ومع بعض الوقت ووضوح الصورة بالشكل الكامل ستصبح نسخة 2013 النسخة الخرافية لتطبيقات الاكسل نصيحة للذين يستخدمون 2003 ستندمون على الايام التي لم تستخدموا النسخ اللاحقة سواء 2007 او 2010

السلام عليكم اخي الكريم قد لا اكون قد فهمت الموضوع بصورة كاملة لكن هنا محاولة قد تفيدك جدول الصف الاول.rar

ما شاء الله عليك اخي جمال ------------- اخي منير استخدم في الكود ActiveCell وليس Target If ActiveCell.HasFormula = True Then ActiveCell.Offset(0, 1).Select

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

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

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

السلام عليكم مبدع اخي عبدالله كعادتك ومن بعد اذنك هنا محاولة اخرى Sub Macro1() Application.ScreenUpdating = False Dim Cont As Integer, rng As Range, R As Integer On Error Resume Next Cont = Application.InputBox("أدخل عدد الصفوف", , 2, , , , , 1) If Cont = 0 Then Exit Sub Set rng = Range([A7], [A65536].End(xlUp)) R = rng.Rows.Count rng(1, 1).EntireColumn.Insert Set rng = rng.Offset(0, -1) rng(1, 1).Value = 1 rng(1, 1).AutoFill Destination:=rng, Type:=xlFillSeries rng.Copy rng.Offset(R, 0).Resize(R * Cont, 1) rng.Resize(R * (Cont + 1), 256).Sort Key1:=rng(1, 1), Order1:=xlAscending, Header:=xlNo rng.EntireColumn.Delete End Sub

السلام عليكم هنا محاولة قد تفيدك تواريخ.rar

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

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

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

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

السلام عليكم ما شاء الله عليك اخي خبور وسلمت يمينك ومن بعد اذنك ولاثراء الموضوع هنا فكرة اخرى Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [d8,j8]) Is Nothing Then Dim my_rng As Worksheet Set my_rng = Sheets("sheet2") If Target.Column = 4 Then Set my_rng = Sheets("sheet1") XX = WorksheetFunction.Match(Target, my_rng.[b1:d1], 0) + 1 X = my_rng.Range("a5000").End(xlUp).Row Target.Offset(1, 0).Resize(X, 1).Value = my_rng.Cells(2, XX).Resize(X, 1).Value End If End Sub هل يمكن عمل حدث change مرتين.rar

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

السلام عليكم اذا تسمحوا لي ... هذه مساهمة مني للموضوع Sub DropDown1_Change() sh_list Sheets(Sheets(1).Shapes("Drop1").ControlFormat.Value).Select End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) sh_list End Sub Sub sh_list() Sheets(1).[a2:a100] = Empty Dim Sh1 As Worksheet For Each Sh1 In ActiveWorkbook.Sheets Sheets(1).Range("a5000").End(xlUp).Offset(1, 0) = Sh1.Name Next Sh1 End Sub sheeet.rar

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

السلام عليكم والله يا ابو نصار انك رائع افكار تحسد عليها وستحقق ما تصبو اليه ان شاء المولى ولاثراء الموضوع هنا تعديل على الكود الاصلي (مع ابقاء التنسيق الشرطي) Static OldCell As Range If Target.Cells.Count <> 1 Then Exit Sub Target.FormatConditions.Delete If Not OldCell Is Nothing Then OldCell.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0" OldCell.FormatConditions(1).Interior.Color = 12632256 OldCell.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 3 Set OldCell = Target او هنا كود اخر لعمل المطلوب ( مع ازالة التنسيق الشرطي) Static OldCell As Range If Target.Cells.Count <> 1 Then Exit Sub If Not OldCell Is Nothing Then OldCell.Interior.ColorIndex = xlColorIndexNone If OldCell.Row Mod 2 = 0 Then OldCell.Interior.Color = RGB(192, 192, 192) End If Target.Interior.ColorIndex = 3 Set OldCell = Target

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

السلام عليكم ما شاء الله عليك اخي ابو نصار مميز ومبدع بحق ............. ..................... مجرد مداخلة لاستخدام الالوان ... هناك خاصيتين تستخدمان للتلوين في الاكسل ( لون الخلية او لون الخط أو ... أو ... ) وهما خاصيتي (Color ,ColorIndex ) الخاصية الاولى والمتعارف عليها هي خاصية (ColorIndex ) وتكون قيمها من 0 الى 65 وهي على النحو التالي : Range("A1").Interior.ColorIndex = 19 اما خاصية (Color ) فهي خاصية اوسع واشمل عند استخدام الامر (RGB) .... جميع الالوان عبارة عن مزج ثلاثة الوان رئيسية وهي الاحمر (Red) و الاخضر (Green) و الازرق (Blue) وبالتالي الامر (RGB) هو مزيج الالوان السابقة (Red, Green, Blue) ويأخذ كل لون من الالوان السابقة القيم من 0 الى 255 وكلما زاد الرقم انخفض حدة اللون (وبلغة الاحتمالات ينتج لدينا أكثر من 16 مليون لون) Range("A2").Interior.Color = RGB(200, 200, 200) ونستطيع معرفة قيمة الارقام المقابلة لاي لون بالذهاب الى صندزق الالوان في الاكسل (لون الخط او لون الخلية) ثم نخنار (More Color) ثم نختار النافذة (custom) وسنجد في الاسفل خاصية (RGB) والارقام الثلاثة المقابلة للون المحدد

السلام عليكم هنا حل اخر لعله يثري الموضوع وهو تعديل للكود الاصلي : Sub abu_ahmad() Dim cl As Range For Each cl In Range("D7:D" & [D1500].End(xlUp).Row) If Len(cl.Value) > 9 And IsDate(Left(cl, Len([E2]))) <> True Then _ cl.Value = [E2].Value & " _ " & cl.Value Next End Sub

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