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

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

السّلام عليكم و رحمة الله و بركاته أخي الكريم محمد عبد السلام ..تجد ملفين مرفقيْن ..أحدهما بكلمة مرور بواسطة اليوزرفورم و الآخر بالأنبت بوكس ..قم باختيار ما يناسبك فائق إحتراماتي محمد عبد السلام.rar

السلام عليكم ورحمة الله وبركاته أحبائى وأساتذتى وأعضاء هذا الصرح العلمى الهائل الذى مهما قدمت له لن أوفيه حقه فيما تعلمت منه الفترة الماضية وبعد قدمت من قبل موضوع بعنوان معادلة بحث جميلة جدا على الرابط ولكن بالمعادلات اليوم أقدم لكم نفس الفكرة ولكن بالأكواد الأكواد المستخدمة الكود الأول فى حدث الشييت : Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Cells(2, 2)) Is Nothing Then: names_by_letters End Sub والكود الثانى يوضع ب Module Sub names_by_letters() Dim myRange As Range Dim i As Integer Dim x As Range i = 2 lr = Cells(Rows.Count, 1).End(xlUp).Row Range("c2:c" & lr).ClearContents Set myRange = Range("a2:a" & lr) For Each x In myRange If Mid(x, 1, 1) = [b2] Then Cells(i, 3).Value = x i = i + 1 End If Next x End Sub أرجوا أن يستفاد منه الجميع والله ولى التوفيق Find By VBA Code.rar

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

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

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

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

ممتاز اخي ياسر والان جرب ان تستبدل سطر الشرط IF بهذا السطر و لاحظ النتيجة If InStr(UCase(x.Value), UCase([b2].Value)) > 0 Then

Sub names_by_letters() Dim myRange As Range Dim i As Integer Dim x As Integer x = 2 LR = Cells(Rows.Count, 1).End(xlUp).Row Range("c2:c" & LR).ClearContents Set myRange = Range("a2:a" & LR) For i = 2 To LR If InStr(1, Cells(i, "A"), [B2], vbTextCompare) Then Cells(x, 3).Value = Cells(i, 1).Value x = x + 1 End If Next i End Sub اخى ياسر البنا مشكورا على الكود الجميل ده بارك الله فيك واسمح لى بالاضافه بحث باى حرف من الاسم مع عدم اشتراط تفعيل caps lock تقبل تحياتى

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

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

بارك الله فيك أستاذ مختار حسين هل فكرت في تطبيق هذه الفكرة على الأشكال (Shapes)أو الأزرار (Forms Buttons) عوض الخلايا بحيث عند تحريك الماوس فوق الشكل او الزر تظهر رسالة معينة

السلام عليكم ورحمة الله وبركاته برجاء المشاركة فى هذا السؤال

السلام عليكم اضن الكثير منا يعلم ماهي الوظائف الإضافيه في الاكسل ومدى اهميتها في اختصار الكثير من الوقت للعمل على روتين معين لأكثر من مصنف انا سأطرح لكم الفكرة والتطبيق والاليه التي استخدمت بها تلك الوظيفه الإضافية أولاً ماهي الوظائف الإضافيه ؟ كخطوة اولى: توضيح وحفظ الوظيفه - هيا عباره عن ملف اكسل به اكواد او فورم او داله ويحفظ بصيغة "Excel Add-In" في المسار "AppData\Roaming\Microsoft\AddIns" او في اي مجلد تريد يكون موقع له فرضاً سميناها "Aosamh" وعند الحاجه لتلك الوظيفه تقوم بتفعيل الوظيفه كي تستخدمها للملف الذي تعمل عليه الخطوة الثانية: تفعيل الوظيفه ( بعد ان حفظتها بالخطوة الاولى ) -من خيارات الاكسل - الوظائف الإضافية - إدارة الوظائف الإظافيه Excel ( تضغط زر المسمى "إنتقال" ) ومن ثم تحفز الوظيفه . الفكرة كالتالي : تقرير مخزون عبر برنامج محاسبي اصدره الى الاكسل واقوم بعمل بعض التنسيقات والتعديلات عليه بشكل اتوماتيك واستخرج منه اعمدة معينه للعمل عليها غرضي من هذه الطريقة عمل " تقرير لأصناف معينه لعمل خصم عليها بطريقة يدويه" خصم يدخل يدوي ومن ثم اجمالي الفارق بين سعر التكلفه القديم وسعر التكلفه الجديد واجمالي الفارق لكل الاصناف في نهاية التقرير ماتطلب علي استخدامة لأنجز تلك الفكره : 1- تصدير التقرير من البرنامج المحاسبي 2- معرفة بعض الكلمات الاساسيه في التقرير المستخرج من البرنامج المحاسبي ( لمعرفة ان الملف هو مانريده كي نفعل عليه الوظيفة الاضافية) 3- عمل بعض التعديلات على الملف من الغاء دمج بعض الخلايا وحذف بعض الاعمدة التي لااستخدمها للغرض الذي اريده وماسبق ذكرة الـ 3 البنود منها عملتها بظريقه يدوية ومن ثم بالكود كي يقوم بما عملته عند استدعائي للوظيفة ( 2 و 3 ) 4- عمل في بعض الاعمدة معادلات عبر الكود ومنها اجمالي التقرير بعد اضافة القيم اليدويه 5- انشاء فورم بحث للبحث عن الاصناف في التقرير سواء برقم الصنف او مرجعه الاكواد المستخدمة في ملف الوظيفة الإضافية كالتالي : 1- كود حدث فتح ملف الاكسل "Auto_Open" -استخدمناه لكي نفعل كود التحقق من ان الملف المفتوح حالياً هو مانريده "تقرير المخزون" ام لا الكود في حدث فتح المصنف بعد 3 ثواني من فتح المصنف ينفذ الكود المسمى "Action_Abad" Sub Auto_Open() Application.OnTime Now + TimeValue("00:00:03"), "Action_Abad" End Sub هذا كود "Action_Abad" يقوم بتنفيذ الدالة "Check_Work" واذا كان نتيجة الدالة True يعني هو الملف المطلوب دالة "Check_Work" تقوم بالبحث في المصنف هل يوجد كلمة "تقييم المخزون" اذا تحقق الشرط تقوم بالتالي Public Const Trgt As String = "تقييم المخزون" Public Function Check_Work() Dim Rng_Chk For Each Rng_Chk In ActiveWorkbook.ActiveSheet.UsedRange.Cells If Trim(Rng_Chk) Like Trgt Then Bl_Open = True Exit Function End If Next End Function تقوم بإنشاء زر اختصار للكود "Ali_Tk" في تبويب الوظائف الاضافية Sub Action_Abad() '=============== Check_Work '' دالة التحقق من الملف المفتوح حالياً '=============== If Bl_Open = True Then Dim cb As CommandBar Dim ctrl As CommandBarControl On Error Resume Next Application.CommandBars("Tol_Abad").Delete On Error GoTo 0 Set cb = Application.CommandBars.Add(Name:="Tol_Abad") With cb .Visible = True .Position = msoBarTop Set ctrl = .Controls.Add(Type:=msoControlButton) With ctrl .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "تقرير_خصم" .FaceId = 107 .OnAction = "Ali_Tk" '' الزر يقوم بتشغيل كود عمل التنسيقات وحذف اعمدة من تقرير المخزون .TooltipText = "تقرير خصم لأصناف" End With End With Bl_Open = False End If End Sub وهذا كود "Ali_Tk" الذي يقوم بعمل تنسيقات للتقرير واضافة اعمدة ودوال واستخراج الاعمدة الاساسية في مصفوفة "Arr" Sub Ali_Tk() Dim Arr Dim RR, Mord, On_Rw Dim Rm As Range Dim Rnn As Range, Rmm As Range Dim Rng As Range A_Application False ActiveWorkbook.ActiveSheet.UsedRange.UnMerge Arr = Array("تقييم المخزون", "‏المورد :‏", "‏م‏", "‏رقم الصنف‏", "‏وصف الصنف‏", "‏رقم المرجع‏", "‏إجمالي الكمية‏", "‏السعر‏") For Each RR In ActiveWorkbook.ActiveSheet.UsedRange.Cells For Each Ar In Arr If Trim(RR) Like Trim(Ar) Then Select Case Trim(RR) Case Is = Arr(0) Case Is = Arr(1) RR.Select Lrm = Selection.End(xlToLeft).Column '' إيجاد عمود اسم المورد Mord = CStr(S_Nm_Ali(Cells(RR.Row, Lrm))) '' إســم المورد On_Rw = RR.Row '' أول صف للجدول Case Else If Not RR Is Nothing Then If Rm Is Nothing Then Set Rm = RR Else Set Rm = Union(Rm, RR) End If End If End Select End If Next Next Rm.EntireColumn.Hidden = True Set Rng = Range("A1:AB1") '************************************************************* Rng.SpecialCells(xlCellTypeVisible).EntireColumn.Delete Range("A1:A" & On_Rw).EntireRow.Delete ActiveSheet.UsedRange.EntireColumn.Hidden = False '************************************************************* Range("A:A,B:B").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '************************************************************* Rows("1:1").RowHeight = 40 Rows("2:2").RowHeight = 28.5 Range("C2") = "تكلفة جديدة" Range("A2") = "الفرق" ActiveSheet.UsedRange.EntireColumn.AutoFit Columns("F:F").ColumnWidth = 11 Columns("E:E").ColumnWidth = 9.14 Columns("G:G").ColumnWidth = 7.57 Columns("G:G").ColumnWidth = 11.57 Columns("G:G").ColumnWidth = 10.71 R = 3 Lr = Cells(Rows.Count, 2).End(xlUp).Row For i = R To Lr Cells(i, 1).Formula = "=IF(RC[2]="""","""",CEILING(IF(RC[2]="""","""",(RC[3]*RC[1])-(RC[3]*RC[2])),1))" Next With Range("A" & Lr + 1) .Formula = "=SUBTOTAL(9," & Range("A3:A" & Lr).Address(0, 0) & ")" .Offset(0, 1).Formula = "=SUBTOTAL(9," & Range("B3:B" & Lr).Address(0, 0) & ")" .Offset(0, 2).Formula = "=SUBTOTAL(9," & Range("C3:C" & Lr).Address(0, 0) & ")" .Offset(0, 3).Formula = "=SUBTOTAL(9," & Range("D3:D" & Lr).Address(0, 0) & ")" End With Range(Cells(3, 1), Cells(Lr + 1, 8)).Borders.Color = 1 Range(Cells(3, 1), Cells(Lr + 1, 8)).RowHeight = 24.75 Range(Cells(3, 1), Cells(Lr + 1, 8)).WrapText = False Columns("A:H").AutoFit Columns("A:D").ColumnWidth = 9 With Range(Cells(3, 1), Cells(Lr + 1, 8)) .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter .Interior.ColorIndex = xlNone With Range("A" & Lr + 1 & ":H" & Lr + 1) .Interior.Color = RGB(252, 228, 214) .Font.ColorIndex = 23 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With Range("A2:H2") .Interior.Color = RGB(252, 228, 214) .Offset(-1, 0).Merge .Offset(-1, 0).RowHeight = 40 .Font.ColorIndex = 23 .Font.Bold = True .Borders.Color = 0 .HorizontalAlignment = xlCenter .VerticalAlignment = xlTop End With End With With ActiveSheet.PageSetup .PrintArea = Range(Cells(1, 1), Cells(Lr + 1, 8)).Address .PrintTitleRows = "$1:$2" .PrintTitleColumns = "" .Zoom = 123 .LeftMargin = Application.InchesToPoints(3.93700787401575E-02) .RightMargin = Application.InchesToPoints(3.93700787401575E-02) .TopMargin = Application.InchesToPoints(3.93700787401575E-02) .BottomMargin = Application.InchesToPoints(3.93700787401575E-02) .HeaderMargin = Application.InchesToPoints(3.93700787401575E-02) .FooterMargin = Application.InchesToPoints(3.93700787401575E-02) .CenterHorizontally = True .CenterVertically = False End With Range("A3").Select ActiveWindow.FreezePanes = True ActiveWindow.SmallScroll Down:=12 Range("C3").Select With Range("A1") .Value = "(" & " طلب خصم بضاعة / " & Mord & " / للمؤسسة " & ")" .Font.Name = "Times New Roman" .Font.Size = 14 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With '===================== Action_Search '' إستدعاء كود إضافة زر اخر في تبويب الوظائف الإضافية _ لإنشاء زر في تبويب الوظائف الإضافية واسمه بحث ليقوم بتنفيذ كود فتح فورم البحث والتعديل '===================== A_Application True End Sub وفي نهاية الكود يستدعي الكود "Action_Search" ليضيف زر اخر في تبويب الوظائف الإضافية واسمه "بحث" لينفذ كود فتح " فورم البحث" Private Sub Action_Search() Dim cb As CommandBar Dim ctrl1 As CommandBarControl Set cb = Application.CommandBars("Tol_Abad") With cb .Position = msoBarTop Set ctrl1 = .Controls.Add(Type:=msoControlButton) With ctrl1 .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "بحث" .FaceId = 1100 .OnAction = "Show_Ali" .TooltipText = " بحث في بيانات الاصناف للمورد" End With End With '====================== Visbl_Control False '' الذي يقوم بعمل تنسيقات تلافياً لعدم الضغط عليه مره اخرى ' إخفاء زر المسمى تقرير_خصم '============== Action_Prnt '' إستدعاء كود لإضافة زر اخر بإسم طباعه لينفذ كود طباعة التقرير بعد الانتهاء من عمل التعديلات عليه '============= End Sub دالة " Visbl_Control" لتقوم بإخفاء زر " تقرير_خصم " تلافياً لعدم الضغط عليه مره اخرى Function Visbl_Control(Vis As Boolean) Application.CommandBars("Tol_Abad").Controls("تقرير_خصم").Visible = Vis End Function كود فتح فورم البحث المسمى " Show_Ali" Sub Show_Ali() Ali_Search.show 0 End Sub وفي نهاية كود "Action_Search" يستدعي كود المسمى "Action_Prnt" ليقوم بإنشاء زر واسمه "طباعه" لينفذ الكود المسمى "Prnt" Private Sub Action_Prnt() Dim cb As CommandBar Dim C As CommandBarControl Set cb = Application.CommandBars("Tol_Abad") With cb .Position = msoBarTop Set C = .Controls.Add(Type:=msoControlButton) With C .BeginGroup = True .Style = msoButtonIconAndCaption .Caption = "طباعه" .FaceId = 180 .OnAction = "Prnt" .TooltipText = " طباعة النتائج " End With End With End Sub وهذا كود الطباعه المسمى " Prnt" ليطبع التقرير بعد عمل التصفية للصفوف الملونه بلون معين Sub Prnt() With ActiveSheet .Range("A2:H2").Select Selection.AutoFilter Ln = .Cells(.Rows.Count, 2).End(xlUp).Row .Range(Cells(2, 1), Cells(Ln, 8)).AutoFilter Field:=6, Criteria1:=RGB(225, 225, 235), Operator:=xlFilterCellColor If .UsedRange.SpecialCells(xlCellTypeVisible).Count <= 24 Then MsgBox "لايوجد نتائج للطباعه", vbInformation, "" .Range("A2:H2").Select Selection.AutoFilter Exit Sub End If .Range("G2").EntireColumn.Hidden = True .PrintPreview .Range("G2").EntireColumn.Hidden = False .Range("A2:H2").Select Selection.AutoFilter .Range("A2").Select End With End Sub وهذا كود حدث اغلاق المصنف " Auto_close "ليقوم بحذف تبويب الوظائف الإضافية بما فيه من ازرار انشأناها وقت الاستخدام Sub Auto_close() On Error Resume Next Application.CommandBars("Tol_Abad").Delete Application.CommandBars("Benefits Survey Toolbar").Delete On Error GoTo 0 End Sub ماأرجوه من طرحي هذا اخذ فكره عن الوظائف الإضافية وبما يمكنها من استخدام اكواد ومعادلات مستحدثه في اكثر من ملف وقت الاستخدام وافكار ان شاء الله يستفاد منها - مرفق ملف شرح فيديو طريقة العمل - وملف التقرير المستخرج من البرنامج المحاسبي - وملف الاكواد والفورم وهو كوظيفة إضافية لم استطيع ارفاق الملفات حملتها عبر 4Share وهذا رابط المرفقات http://www.4shared.com/rar/x33ci575ba/_online.html والسلام عليكم

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

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

أخي الغالي محمد وجزيت خيراً بمثل ما دعوت وزيادة كنت بتقطع في فروتي مع مين يا ترى ؟؟!!! ..

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

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

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

بعد اذن الاستاذ جعفر واثراء للمعلومة اكتب التعبير التالي في مربع نص للنموذج الفرعي وللارقام السالبة =Sum(IIf([الرصيد]<0;[الرصيد];0)) وطبعا للموجبة تغيير فقط الاشار الى اكبر من الصفر ويبقى سحب القيمة للنموذج الرئيسي واخفاء الاصلي بالنموذج الفرعي وهذه اتوقع معلومة ومعروفة ! هنا افضل وبعد الارتباط بحدث معين او حتى عند الفلترة تتغير الحسبة ! بالتوفيق

بارك الله فيك أستاذنا جعفر ردا على سؤالك نعم فكرت لكن لم أصل لشىء حتى الآن Macro When Your Mouse is over a Image1.rar

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

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

السلام عليكم الى حلول الاخوة الكافيه الوافيه بطريقه اخرى Public Ali_1() Dim Lr&, Rw&, Rng As Range Application.ScreenUpdating = False Lr = Range("A" & Rows.Count).End(xlUp).Row: Range("A3:B" & Lr).Copy [E3] Set Rng = Range("E" & Lr + 10) For Rw = 3 To Lr If Application.CountIf(Range("E3:E" & Rw), Range("E" & Rw)) > 1 Then Set Rng = Union(Rng, Range("E" & Rw)) Else Cells(Rw, 6) = Application.SumIf(Range("E:E"), Range("E" & Rw), Columns(6)) End If Next Rw Union(Rng, Rng.Offset(0, 1)).Delete Shift:=xlUp: Set Rng = Nothing Application.ScreenUpdating = True End Sub

السلام عليكم و رحمة الله وبركاته اخي ابو عمار في المرفق ادخل رقم الموظف تظهر بياناته اذا كان موجود من السابق تظهر بياناته عدل ماتريد و اضغط اضافه او تعديل اذا كان الرقم غير موجود من السابق قم باضافة البيانات الجديدة و اضغط اضافه او تعديل آمل ان يكون هذا المطلوب موظفين-ابوعمار.rar

السّلام عليكم و رحمة الله و بركاته فعلاً شاشة دخول رائعة ..بارك الله فيك و زادك من علمه و فضله فائق إحتراماتي

أخي الكريم متخافش من المحاولة أبداً اتجرأ ... رقم الإصدار بيختلف من نسخة لأخرى .. إنت هتلاقي عندك رقم واحد حسب النسخة المثبتة لديك ... يعني خلاصة كلامي مفيش مشكلة من رقم الإصدار في الـ Reference ..المهم تكون نفس المكتبة الخاصة بالورد Microsoft Word .... Object Library

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

لا استطيع الا ان اتدخل بهذا الكود Sub sumif_order() Range("e3:f100").Clear LR = Cells(Rows.Count, 1).End(3).Row Set Myrg = Range("a3:a" & LR) For I = 3 To LR If Application.CountIf(Range("a3:a" & I), Range("a" & I)) = 1 Then Cells(k + 3, 5) = Range("a" & I) k = k + 1 End If Next LRe = Cells(Rows.Count, 5).End(3).Row - 2 Range("E3:F" & LRe).Sort Key1:=Range("E1:E" & LRe), Order1:=xlAscending, Header:=xlNo Range("f3:f" & LRe + 2).Formula = "=SUMIF($A$3:$A$100,E3,$B$3:$B$100)" End Sub

السلام عليكم ورحمة الله وبركاته بعد ان استفاضنا فى المناقشات فى هذه المشاركة http://www.officena.net/ib/topic/63756-نسخ-قاعدة-بيانات-الجداول-المرتبطة-فقط-عند-الخروج/ وقام استاذنا ابوخليل بامدادنا بكود اكثر من رائع .. فبارك الله فيه وجزاه الله عنا كل الخير له ولاولاده Shell "cmd.exe /C copy " & """" & DBOld & """" & " " & """" & _ DBNew & "\" & Format(Now(), "yymmddhhnn") & ".mdb" & """", 0 فخطرة ببالى فكرة تطوير اداه (لضبط خيارات النسخة الاحتياطية للجداول المرتبطة عن طريق قاعدة الواجهات كل فترة زمنية بطريقة تلقائية ساعة / يوم / شهر / سنة) والكود الذى امدنا به استاذنا العزيز ابو خليل يتحكم فى الموضوع ولكن من داخل الكود ــ بمعنى لو انت حبب تعمل نسخة كل ساعة عند الخروج من البرنامج لازم ترجع للكود وتحذف hh وهكذا على النحو المشار بالمشاركة المدرج رابطها بعاليه yymmddhhnn الفكرة تتلخص فى نموذج تظبط منه الاعدادات التالية وتحفظ الاعدادات لمرة واحدة واذا ارات تغيير الاعدادات عليك بالذهب الى النموذج واعادة الضبط مرة اخرى وهكذا انظر الصورة المطلوب هو التعديل على الكود حتى يتناسب مع النموذج المرفق حسب ما هو مبين بالصورة مرفق القاعدة main1.rar برجاء فك الضغط داخل البارتشن ال D محمد سلامة main1.rar

مشكور اخي محمد ! والمنتدى له وحشة ! تحياتي

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

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

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

السلام عليكم جرب هذا الكود Sub Abad_Tr() Dim Sh As Worksheet Dim Shn As Worksheet Dim Cl, Cl1, Rw Dim Nm_1 As String Set Sh = Sheets("قيد اليومية") For R = 10 To 32 If Sh.Cells(R, "H") <> "" Then If Val(Sh.Cells(R, "D")) <> Val(Sh.Cells(R, "E")) Then MsgBox "يوجد خلل في القيد فارق بين الدائن والمدين" & R Exit For Exit Sub End If If Sh.Cells(R, "D") <> "" Or Sh.Cells(R, "E") <> "" _ Or Sh.Cells(R, "F") <> "" Or Sh.Cells(R, "G") <> "" _ Or Sh.Cells(R, "H") <> "" Then Nm_1 = Shet_My(Sh.Cells(R, "H")) If My_Shet(Nm_1) = True Then Set Shn = Sheets(Nm_1) With Shn Cl = Clumn_My(Shn, Sh.Cells(R, 6), "F") Cl1 = Clumn_My(Shn, Sh.Cells(R, 7), "G") Rw = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Cells(Rw, Cl) = Sh.Cells(R, 4) .Cells(Rw, Cl1) = Sh.Cells(R, 5) .Cells(Rw, 3) = Sh.Cells(R, 8) .Cells(Rw, 1) = Sh.Cells(7, 9) .Cells(Rw, 2) = Sh.Cells(4, 7) & "/" & Sh.Cells(4, 6) & "/" & Sh.Cells(4, 5) End With End If Else MsgBox "يوجد فراغ في احد بنود القيد قم بتصحيحه واعد تنفيذ الكود" Exit For Exit Sub End If End If Next Sh.Range("D10:I32").ClearContents Sh.Range("I7").ClearContents End Sub Private Function Shet_My(Nm As String) As String Dim Sht As Worksheet For Each Sht In Sheets If Nm Like "*" & Sht.Name & "*" Then Shet_My = Sht.Name Exit Function End If Next End Function Function My_Shet(Sh_Nm As String) As Boolean If Sh_Nm = "" Then My_Shet = False: Exit Function My_Shet = Evaluate("ISREF('" & Sh_Nm & "'!A1)") End Function Private Function Clumn_My(Sn As Worksheet, Nm$, Num As String) As Integer Dim C, Lc Lc = Sn.Range(Split(Sn.UsedRange.Address, "$")(3) & 1).Column For C = 4 To Lc If Sn.Cells(4, C) Like Nm Then Select Case Num Case Is = "F" Clumn_My = Sn.Cells(4, C).Column Case Is = "G" Clumn_My = Sn.Cells(4, C + 1).Column End Select Exit Function End If Next End Function

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

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

انت كدا جيت في ملعبي تفضل الموضوع دا لو عرفت تطبقه كان بها معرفتش هحاول اظبطه ليك وارفقه http://www.officena.net/ib/topic/64269-لمسة-جمالية-لبرنامجك-ايا-كان-هو-عرض-صور-بطريقة-جميلة/

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

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

الأول إخفاء كل التبويبات وزر الأوفيس Sub hhh() Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",false)" End Sub الثاني إظهار كل التبويبات وزر الأوفيس Sub sss() Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",true)" End Sub

أخى أبا عبدالرحمن جرب هذا الملف قد يقيدك Test .rar

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

أخي الكريم نور وحيد جرب الكود التالي عله يفي بالغرض Sub Summary() Dim I As Long, J As Long, M As Long, N As Long, LR As Long, V, ZUM Dim C As Collection Set C = New Collection Application.ScreenUpdating = False On Error Resume Next For I = 3 To Rows.Count V = Cells(I, 1).Value If V = "" Then N = I - 1 Exit For End If C.Add V, CStr(V) Next I On Error GoTo 0 M = 3 For I = 1 To C.Count Cells(M, 5) = C.Item(I) ZUM = 0 For J = 3 To N If Cells(J, 1).Value = Cells(M, 5).Value Then ZUM = ZUM + Cells(J, 2).Value End If Next J Cells(M, 6).Value = ZUM M = M + 1 Next I LR = Range("E" & Rows.Count).End(xlUp).Row Range("E3:F" & LR).Sort Key1:=Range("E1:E" & LR), Order1:=xlAscending, Header:=xlNo Application.ScreenUpdating = True End Sub وإليك الملف المرفق الخاص بك Unique Items With SUM & Sort YasserKhalil.rar

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

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

سادسا :- اجبار المستخدم على الاختيار من الكمبوبوكس يوجد طريقتين الطريقه الاولى :- هى استخدام الخاصيه Style اثناء شرحنا لخصائص الكمبوبوكس فى مرحلة التصميم تكلمنا عن الخاصيه Style ودا نسخ الجزئيه الخاصه بالخاصيه Style من شروحتنا السابقه الخاصيه ( Style ):- وهى بنظرى من اهم الخصائص للكمبوبوكس زى ما احنا عارفين لفتح القائمة الخاصه بالكمبوبوكس للاختيار منها لابد من الضغط على السهم لتفتح القائمه ولكن هذه الخاصيه تتيح للمستخدم التحكم فى وقت فتح القائمة الخاصه بالكمبوبوكس فلها خيارين الخيار الاول Fm StyleDropDown Combo - 0 :- هو الافتراضى لابد من الضغظ على السهم لفتح القائمة كما تتيح للمستخدم كتابة اى شئ بالكمبوبوكس غير موجود بالقائمه بمعنى لا تلزم المستخدم من الخيار من القائمة والخيار الثانى Fm StyleDropDown List - 2 : -هو فتح القائمة من خلال الضغط على السهم او بمجرد وقوف مؤشر الماوس على الكمبوبوكس وكمان ميزة ثالته وهى مهمه جدا هو انه لا يمكن للمستخدم كتابة اى شئ فى الكمبوبوكس يعنى كانك عامل خاصيه حمايه للكمبوبوكس ولا سبيل امام المستخدم الا من الاختيار من القائمه -------------------------------------------------------------------------------------------- الطريقه الثانية :- استخدام الخاصيه MatchFound عايزين نعمل كود يقوم باختبار قيمة الكمبوبوكس هل هى موجوده بالقائمه او لا ؟ لو الكمبوبوكس التطابق مع القائمة = خطأ نفذ الكمبوبوكس فارغ ( دا شرح الكود كدا بالبلدى وحنا قاعدين على المصطبه) لتحويل الكلام اللى بالبلدى ده الى لغة البرمجه تابع معايا لو نستبدلها بـ IF (يعنى قاعدة IF) الكمبوبوكس نستبدله باسم الكمبوبوكس المراد العمل عليه وهو على سبيل المثال Me.ComboBox1 التطابق مع القائمه دى الخاصيه Match Found بمجرد كتابة اسم الكمبوبوكس ثم . ثم حرف M ستجد الفيجوال بيسك يعرض لك قائمه للاختيار شاهد الصوره التاليه = خطأ False ( أى ان القيمة المختاره غير موجوده بالقائمه ) نفذ Then الكمبوبوكس فارغ " " شاهد الكود لما نجمع الكلام ده بقى هيكون كالتالى If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If طيب ما هو وقت تنفيذ الكود وقت التنفيذ انت اللى بتحدده مثلا ممكن يكون فى حدث تغيير الكمبوبوكس ()Private Sub ComboBox1_Change Private Sub ComboBox1_Change() If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If End Sub وبكدا لو عندك قائمه الكمبوبوكس وليكن بها ( مصر & السعودية & السودان & الجزائر ) والمستخدم تجاهل هذه القائمة وراح يكتب تونس بمجرد بس كتابة حرف ت سوف يقوم الكود بالعمل مش هيلاقى دوله فى القائمة تبدأ بحرف ت اذن تحقق شرط عدم التطابق فهيقوم بمسح حرف ت ممكن واحد يفتكر فى عفريت مسح الحرف يعنى كل ما تكتب شئ غير موجود بالقائمه هتلاقيه بيتمسح فورا ----------------------- ممكن نكتب الكود فى وقت حدث الخروج من الكمبوبوكس Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" End If End Sub يعنى المستخدم بمجرد ما يكتب تونس ويضغط انتر للانتقال الى عنصر اخر على الفورم هتلاقى الكود بيتنفذ ويمسك المستخدم من قفاه ويقوله تعالى تونس غير موجوده فى قائمة الكمبوبوكس وهيمسح تونس يعنى كأن المستخدم مكتبش اى حاجه ومازل الكمبوبوكس قيمته فارغه ممكن المستخدم يتجنن هو ايه اللى بيحصل هو ليه كل ما اكتب تونس يتم مسحها هو فى عفريت ؟؟ ما عفريت الا بنى ادم فعلشان نريحه نظهر له رساله تفيد بانه يجب الاختيار من القائمه Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then ComboBox1 = "" MsgBox " الرجاء الاختيار من القائمة", vbCritical, "خطأ" End If End Sub قمنا باضافه هذا السطر بالكود قبل نهاية IF MsgBox " الرجاء الاختيار من القائمة", vbCritical, "خطأ" الرساله تتكون من ثلاث اقسام يفصل ما بين كل قسم وقسم علامة , القسم الاول وهو الرساله " الرجاء الاختيار من القائمه" وتم وضعها بين علامتى تنصيص ( وهو قسم اجبارى) القسم الثانى وهو نوع الرساله واظهار علامه لها فكتبنا Vbcritical رساله خطأ ( وهو قسم اختيارى يمكن الاستغناء عنه ) القسم الثالث وهو عنوان الرساله فكتبنا "خطأ" وممكن تكتب اى عنوان كما تشاء ( وهو قسم اختيارى يمكن الاستغناء عنه) فالاساس فى الرساله هو نص الرساله " الرجاء الاختيار من القائمة " MsgBox فأذا ارد اظهار علامه للرساله او عنوان لها قم باضافه القسم الثانى والثالث او استكفى بالقسم الاول اذا حبيت شاهد الرساله عند الاختيار الخاطئ من المستخدم هل يمكن كتابة الكود فى سطر واحد ؟ نعم يمكن ذالك Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Me.ComboBox1.MatchFound = False Then: ComboBox1 = "": MsgBox "الرجاء الاختيار من القائمة", vbCritical, "خطأ": Exit Sub End Sub كما تشاهدون الكود انه فى سطر واحد فقط وذالك باستخدام : : ( تكتب من خلال الضغط على شيفت + حرف ك بالعربى ) واستبدلنا عبارة End if بــ Exit Sub -------------------------------------------------------------------------------------------------------------------- الحمد لله انتهينا من شروحات الكمبوبوكس والى لقاء اخر من حلقات سلسلة علمنى كيف اصطاد ان شاء الله هيكون عن الـــ Frame انتظرونا تقبلوا تحياتى

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

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