اذهب الي المحتوي
أوفيسنا

الحسامي

المشرفين السابقين
  • Posts

    730
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    13

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

  1. السلام عليكم حسب فهمي لطلبك مرفق ملف وفيه كبسة لعمل الخيارات المطلوبة اتمنى ان يلبي طلبك choice.rar
  2. اخي الغالي ياسر ... الله وحده الذي يعلم مدى شوقي وحبي لكم اخي رجب ... النور نورك يا كبير اخي ابراهيم .. بارك الله فيك اخي حسام ... كلامك يدل على علو اخلاقك وان شاء الله لن نتغيب
  3. السلام عليكم احبائي ايه يا عم ياسر العزومة لناس وناس بس على العموم ملحوقة ----------------- وبعد اذن اخي رجب هنا كود اخر لاثراء الموضوع 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
  4. والله مجهود خرافي وافكار جميله ويدل على المستوى العالي الذي تتمتع به بارك الله فيك
  5. لا اصدق ما اراه هل هناك ما زال يستخدم نسخة 2003 النسخة الامثل للاستخدام 2010 بالرغم من الاضافات الخيالية لنسخة 2013 ومع بعض الوقت ووضوح الصورة بالشكل الكامل ستصبح نسخة 2013 النسخة الخرافية لتطبيقات الاكسل نصيحة للذين يستخدمون 2003 ستندمون على الايام التي لم تستخدموا النسخ اللاحقة سواء 2007 او 2010
  6. السلام عليكم اخي الكريم قد لا اكون قد فهمت الموضوع بصورة كاملة لكن هنا محاولة قد تفيدك جدول الصف الاول.rar
  7. ما شاء الله عليك اخي جمال ------------- اخي منير استخدم في الكود ActiveCell وليس Target If ActiveCell.HasFormula = True Then ActiveCell.Offset(0, 1).Select
  8. المنتدى منور بك اخي خبور لا حرمنا الله من علمك وخلق الطيب وما منعا الا هموم الحياة واشغالها بارك الله فيك وفي احبائك
  9. السلام عليكم اخي الحبيب حمادة لا اجد الكلمات التي تعبر عن الشعور لهذا الكلام الطيب وسعادتي اكبر بلقاءكم ولا حرمن الله منكم
  10. اخي ابو نصار بارك الله فيك على اخلاقك العالية اخي حمادة والله الوحشة ميتبادلة ولم يمنعني الا الشديد القوي وان شاء المولى ساتواجد على قدر الامكان لك كل الاحترام
  11. السلام عليكم مبدع اخي عبدالله كعادتك ومن بعد اذنك هنا محاولة اخرى 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
  12. السلام عليكم هنا محاولة قد تفيدك تواريخ.rar
  13. الف مليون مليون مبارك اخي الحبيب يحياوي ترقية مستحقة وبجدارة فاعمالك شاهدة على ابداعاتك اتمنى لك التقدم والنجاح
  14. السلام عليكم انجاز يسجل في تاريخ الاكسل العربي بارك الله فيك واتمنى لك دوام التقدم والنجاح
  15. السلام عليكم عذرا على التاخير اخي سعيد هنا تعديل قد يكون المطلوب حسب وصول الصورة لي وغير ذلك اعلمني اخي الحبي ابو نصار شاكرا لك لمرورك الطيب وكلامك الاطيب وبالتوفيق حساب قيمة خلال مدتان مختلفتان - عماد الحسامى - سعيد بيرم3.rar
  16. اللهم اغفر له وارحمه وعافه واعف عنه وأكرم نزله ووسع مدخله واغسله بالماء والثلج والبرد ونقه من الخطايا كما ينقى الثوب الأبيض من الدنس وأبدله دارا خيرا من داره وأهلا خيرا من أهله وزوجا خيرا من زوجه وأدخله الجنة وأعذه من عذاب القبر ومن عذاب النار اللهم ارحمه وارحم جميع موتى المسلمين
  17. السلام عليكم ما شاء الله عليك اخي خبور وسلمت يمينك ومن بعد اذنك ولاثراء الموضوع هنا فكرة اخرى 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
  18. اخي سعيد هذا الكود هو دالة معرفة ولست كود بالمعنى الادق وليست خاصة بخلية معينة وتستطيع التعامل معها لاي خلية وهذه الدالة شملت جميع الحالات السابقة والجديدة امسح الدالة السابقة واستخدم هذه الدالة فقط
  19. السلام عليكم اذا تسمحوا لي ... هذه مساهمة مني للموضوع 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
  20. السلام عليكم يبدو اخي سعيد ان موضوعك متشعب جدا واخذ مني وقت حتى فهمت الفكرة وحسب فهمي للفكرة هنا الدالة معدلة حسب الشروط السابقة جميعها عسى ان تكون ما تطلب بارك الله على شعورك الطيب ولكني لست متزوج والحمد لله حساب قيمة خلال مدتان مختلفتان - عماد الحسامى - سعيد بير21.rar
  21. السلام عليكم والله يا ابو نصار انك رائع افكار تحسد عليها وستحقق ما تصبو اليه ان شاء المولى ولاثراء الموضوع هنا تعديل على الكود الاصلي (مع ابقاء التنسيق الشرطي) 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
  22. السلام عليكم اخي العزيز سعيد بيرم وكأنك وضعتنا في متاهة كبيرة احتجت لساعات حتى افهم المطلوب على قدر ما استطعت ان افهم من مطلبك هنا دالة معرفة لما تريد قد تكون ما تطلب (ان شاء الله) واذا كانت ليست كذلك فاعلمنا بما اخطانا وعذرا على التاخير حساب قيمة معينة خلال مدتين مختلفتين1 - سعيد بيرم.rar
  23. السلام عليكم ما شاء الله عليك اخي ابو نصار مميز ومبدع بحق ............. ..................... مجرد مداخلة لاستخدام الالوان ... هناك خاصيتين تستخدمان للتلوين في الاكسل ( لون الخلية او لون الخط أو ... أو ... ) وهما خاصيتي (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) والارقام الثلاثة المقابلة للون المحدد
  24. السلام عليكم هنا حل اخر لعله يثري الموضوع وهو تعديل للكود الاصلي : 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
  25. السلام عليكم ورحمة الله وبركاته اللهم رب الأرباب مجري السحاب منزل الكتاب هازم الأحزاب يا من رف السماوات بغير عمد فلم يعجزونه ويا من شق البحر لموسى ويا من فلق الحجر لصالح ويا من له الملك والملكوت والسماوات مطويات بيمينه يا من لا يعجزه شيء ولا يغفل عن شيء يا ودود يا ذو العرش المجيد يا فعال لما تريد يا من عنت الوجوه لعظمته بحق قدرتك على خلقك وبحق أن تقيم الأشهاد ليوم عظيم وبحق أنك من حد الحدود وشرع الشرع وارسل الرسل وبحق أنه لا إله إلا أنت الحي القيوم أسألك أن تكرم الشهداء وتتوب على العاصين من الأمة وتشفي مرضانا وتغفر لشهدائنا وترحم أمة محمد رحمة عامة وكما أسألك أن تنتقم ممن قتل الشهداء من المسلمين أو تآمر عليهم أو أعان عليهم ولو بكلمة أو رضي عن قتلهم اللهم انتقم منهم جميعا هم وأبنائهم ونسائهم ومن أحبهم وأقتلهم قتل عاد وأرم وإجلهم لمن خلفهم آية حتى لا يطغون ولا يفتنون ضعاف الإيمان والحمد لله رب العلمين وصلي وسلم على سيد الخلق أجمعين اللهم آمين آمين آمين آمين آمين ................................................ لم اتصفح البرنامج بعد ولكني على يقين بانه اكثر من رائع كباقي اعمالك السابقة وعذرا على التقصير
×
×
  • اضف...

Important Information