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

لا تحفظ الملف بصيغة ( xlsx ) بل احفظ الملف بأحد هذين الصيغ xlsm or xlsb

وعليكم السلام-فقط عليك استخدام هذه المعادلة =SUMIF($A:$A,$D2,$B:$B) اجمالي كمية بنفس التاريخ1.xlsx

حرب هذا الماكرو Option Explicit Sub get_my_studiants() Application.ScreenUpdating = False Dim A As Worksheet Dim B As Worksheet Set A = Sheets("ALL_STD") Set B = Sheets("B") Dim col%, r, x, LB LB = B.Cells(Rows.Count, "B").End(3).Row If LB < 5 Then LB = 5 B.Range("a5").Resize(LB - 4, 6).Clear Dim my_clas$: my_clas = B.Range("e2") Dim my_mad$: my_mad = B.Range("K2").Value If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub col = A.Rows(1).Find(my_clas, lookat:=1).Column r = A.Columns(1).Find(my_mad, lookat:=1).Row x = Application.CountIf(A.Columns(1), my_mad) B.Range("b5").Resize(x).Value = _ A.Cells(r, 2).Resize(x).Value B.Range("c5").Resize(x, 3).Value = _ A.Cells(r, col).Resize(x, 3).Value With B.Range("A5").Resize(LB - 4, 6) .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)" .Columns(1).Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)" .Value = .Value .Font.Size = 26 .Font.Bold = True .InsertIndent 1 End With Exit_Sub: Application.ScreenUpdating = True End Sub الملف مرفق My_students.xlsm

أ.عماد محمد عبد العزيز جرب المرفق عسى أن يكون المطلوب مع مراعاة أن 2020 ستتغير كل عام .. أم أنك تريدها ثابته التوريد.accdb معذرة أخى Shivan Rekany لم أنتبه لردك

هذه ملف لشرح الطباعه معاينة الطباعه.xlsm

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

وعليكم السلام اهلا بك في منتداك اتفضل اليك هذا استعلام الجدولي TRANSFORM Min([111].[الحالة]) AS MinOfالحالة SELECT [111].[رقم] FROM 111 GROUP BY [111].[رقم] PIVOT [111].[السنة]; مع المرفق ask access.rar تقبل تحياتنا

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

اتفضل القي نظرتا الى هذا تم استخدام هذا الكود مع اضافة حقل id باستخدام دالة dmax + 1 If IsNull(Me.Purchase__Order__No) = True Then Me.id = Nz(DMax("[id]", "Order"), 0) + 1 Me.Purchase__Order__No = Nz(DMax("id", "Order"), 0) + 1 & "/" & 2020 DoCmd.RunCommand acCmdSaveRecord Me.id.DefaultValue = Nz(DMax("[id]", "Order"), 0) + 1 End If التوريد-.mdb

تفضل وذلك بوضع هذا الكود فى حدث ThisWorkBook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Define your variables. Dim ws As Worksheet, EvalRange As Range 'Set the range where you want to prevent duplicate entries. Set EvalRange = Range("A1:a10000") 'If the cell where value was entered is not in the defined range, if the value pasted is larger than a single cell, 'or if no value was entered in the cell, then exit the macro. If Intersect(Target, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub If IsEmpty(Target) Then Exit Sub 'If the value entered already exists in the defined range on the current worksheet, throw an 'error message and undo the entry. If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then MsgBox Target.Value & " already exists on this sheet." Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If 'Check the other worksheets in the workbook. For Each ws In Worksheets With ws If .Name <> Target.Parent.Name Then 'If the value entered already exists in the defined range on the current worksheet, throw an 'error message and undo the entry. If WorksheetFunction.CountIf(Sheets(.Name).Range("A1:a10000"), Target.Value) > 0 Then MsgBox Target.Value & " already exists on the sheet named " & .Name & ".", _ 16, "No duplicates allowed in " & EvalRange.Address(0, 0) & "." Application.EnableEvents = False Application.Undo Application.EnableEvents = True Exit For End If End If End With Next ws End Sub عدم تكرار المدخلات - 1.xlsm

السلام عليكم 🙂 هناك الكثير من الميزات/الاوامر التي يعطينا برنامج الاكسس ، والتي يمكن ان نعمل لها بديل ، ولكن يكون هناك فرق في سرعة تنفيذ كودنا مقارنة مع الكود الاصل من الاكسس !! مثل القائمة المختصرة التي تظهر لنا بالنقر على زر الفأرة الايمن ، والتي بها يمكننا ان نستغني عن الكثير الاوامر ، مثل الفرز والتصفية بأنواعه ، ولكن وللأسف الشديد ، فأنا ارى ان 99.99% من البرامج ، يتم حذف هذه القائمة وعدم تفعيلها ، والسبب ان المستخدم يستطيع ان يدخل في تصميم النموذج من خلال هذه الاوامر(في الدائرة الحمراء) : و . ويضطر المبرمج ان يعوض بقية الاوامر في القائمة ، بمجموعة من الازرار ، او بطرق مختلفة !! ----------------------------------------------------------------------------------------------- الاكسس يسمح لنا ان نعمل قوائم مختصرة Shortcut Menu والتابعة لمجموعة CommandBars ، حسب احتياجنا ، ونختار ما نضعه فيها 🙂 هناك 3 انواع من هذه القوائم : الثابته ، والمؤقته ، والمؤقته التي تحتاج الى كود. الثابته: وهي التي عندما نعملها ، تصبح مستقله عن الكود ، وتُحفظ وتبقى في قاعدة البيانات بعد إغلاقها ، ويمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى ، بإستخدام : . ونختارها في النموذج : . او التقرير : . هذا مثال لعمل الكود الاساس لعمل قائمة قطع/نسخ/لصق : Option Compare Database Option Explicit Dim cmb As Object Dim cmbCtrl As Object Dim cmbName As String ' ' ' to use: ' Dim cbr As Commandbar ' Dim cbrButton as CommandbarControl ' ' we have to select in the References: ' Microsoft Office xx.x Object Library ' Public Function SCM_Copy(Optional DeleteMe As Boolean = False) On Error Resume Next 'If menu with same name exists delete cmbName = "cmb_Copy" CommandBars(cmbName).Delete If DeleteMe = True Then Exit Function If Err.Number <> 0 Then Err.Clear Set cmb = CommandBars.Add(cmbName, msoBarPopup, False, False) With cmb .Controls.Add msoControlButton, 21, , , False ' Cut .Controls.Add msoControlButton, 19, , , False ' Copy .Controls.Add msoControlButton, 22, , , False ' Paste End With Set cmb = Nothing End Function . وشرح الكود : 1. اسم القائمة المختصرة ، والتي سوف نختارها في النموذج او التقرير ، 2. هذه المجموعة الاساس منبثقة Popup ، 3. بينما هذه المجموعات عبارة عن ازرار Buttons ، وقد تكون قائمة منسدلة Combobox ، او نص Edit نُدخل فيه قيمة معينة للتصفية مثلا ، 4. هل هذه القائمة مؤقته ؟ False معناها ثابته وتُحفظ في قاعدة البيانات ، بينما True معناها انها مؤقته وتعمل لما ننادي الوحدة النمطية/الكود ، 5. هذه ارقام كل امر ، وملف الاكسل المرفق من مايكروسوفت فيه جدول يضم جميع ارقام الاوامر للاكسس 2010 () ، 6. اذا اردنا ان نحذف هذه القائمة ، فننادي الوحدة النمطية بضم True في امر المناداة المؤقته: ونستعمل True في مكان الرقم 4 اعلاه. وهي التي عندما نعملها ، لا تصبح مستقله عن الكود ، ولا تبقى في قاعدة البيانات بعد إغلاقها ، ولا يمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى (كما هو الحال مع القائمة الثابته) ، ويجب ان نستخدم "حدث فتح" النموذج/التقرير لعملها واستخدامها في النموذج/التقرير ، و "حدث اغلاق" النموذج/التقرير لحذفها ، طيب ، خلونا نعمل هذه القائمة : Public Function SCM_Copy_Sort(Optional DeleteMe As Boolean = False) On Error Resume Next 'If menu with same name exists delete cmbName = "cmb_Copy_Sort" CommandBars(cmbName).Delete If Err.Number <> 0 Then Err.Clear Set cmb = CommandBars.Add(cmbName, msoBarPopup, False, False) With cmb Set cmbCtrl = .Controls.Add(msoControlButton, 21, , , False) ' Cut cmbCtrl.Caption = "Cut..." cmbCtrl.FaceId = 21 Set cmbCtrl = .Controls.Add(msoControlButton, 19, , , False) ' Copy cmbCtrl.Caption = "Copy..." cmbCtrl.FaceId = 19 Set cmbCtrl = .Controls.Add(msoControlButton, 22, , , False) ' Paste cmbCtrl.Caption = "Paste..." cmbCtrl.FaceId = 22 Set cmbCtrl = .Controls.Add(msoControlButton, 210, , , False) 'Sort Ascending cmbCtrl.BeginGroup = True cmbCtrl.Caption = "فرز تصاعدي..." cmbCtrl.FaceId = 210 Set cmbCtrl = .Controls.Add(msoControlButton, 211, , , False) 'Sort Decending cmbCtrl.Caption = "فرز تنازلي..." cmbCtrl.FaceId = 211 End With Set cmb = Nothing End Function . وشرح الكود: احنا توسعنا في الكود الاساسي ، واضفنا له : 1. تسمية اختيارية غير الافتراضية ، لاحظ في الصورة اعلاه اني استعملت الانجليزي والعربي ، 3. وهو لعمل خط فاصل في الصورة بين مجموعة قطع/نسخ/لصق ومجموعة فرز تصاعدي/تنازلي ، . 2. ممكن ان نبدل الصورة الافتراضية التي تيجي مع الرقم ، بتبديل هذا الرقم (لاحظ صورة الاسهم للتصاعدي/التنازلي) : . ومرفق ارقام جميع الصور الموجودة في الاكسس : . . . . . . . . . . . في قاعدة البيانات المرفقة myRight_Click.mdb ، بالاضافة الى القوائم الثابته اعلاه ، تم اضافة هذه القائمة ايضا : . والتقرير يحتوي على القائمة المؤقته التالية : . - ملف الاكسل myList.xlsx ، اخترت فيه اهم القوائم في وجهة نظري ، - ملف الاكسل AccessControls_2010.xlsx ، من مايكروسوفت ، يحتوي على جميع الاوامر 🙂 جعفر المصادر: http://dev-soln.com/access-shortcut-right-click-tool/ https://www.experts-exchange.com/articles/12904/Understanding-and-using-CommandBars-Part-II-Creating-your-own.html https://filedb.experts-exchange.com/incoming/2014/02_w06/833359/CommandBars-II.mdb https://www.experts-exchange.com/articles/18341/CommandBars-Part-III-Using-Built-in-Shortcut-Menus.html http://www.skrol29.com/us/vtools.php AccessControls_2010.xlsx myList.xlsx myRight_Click.zip

لعمل حفظ مرتبط بمايكرو يجب حفظ الملف باسم وبعد ذلك اختر امتداد .xlsm لكي يعمل الملف ويتنفذ الكود

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

جرب المرفق HCT Permit To Work System V.02 - Update _Normal + Red Zon - Copy.rar

في الاعدادات الغي علامة صح امام هذه المربعات

تفضل تم تعديل الأكواد بناءا على تعليمات وتوجيهات الأستاذ ابراهيم برنامج الصادر والوارد تصميم 2020.xls

اجعله نموذج منقسم وأضف زر الأمر الذي تريد كما في المرفق . 1.accdb

بعد أذن اخونا سليم حاصبيا اخ ابو العلاء ما هو الحد الأقصي لعدد الأكواد

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

جرب هذا الملف order_up_to_1000.xlsm

جرب هذا الكود (حدد البوكس ثم انتقل الى اي خلية او اضغط Enter) Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) tesl End Sub '+++++++++++++++++++++++++++++ Sub tesl() Dim cb As CheckBox, n For Each cb In Me.CheckBoxes cb.TopLeftCell.Offset(1, -1).NumberFormat = _ IIf(cb.Value <> 1, ";;;", "General") Next cb End Sub الملف مرفق( شيت Key) TEST_xxx (3).xlsm

تفضل يمكنك وضع استخدام هذا الكود بحدث الصفحة , بحيث يقوم بإدراج صف فارغ بمجرد إدخال تاريخ مختلف Private Sub Worksheet_Change(ByVal Target As Range) Dim L& If Target.Address = Cells(Rows.Count, 5).End(xlUp).Address Then If IsDate(Target) And IsDate(Target(0)) Then If Target.Value2 <> Target(0).Value2 Then Application.EnableEvents = False Application.ScreenUpdating = False Target.EntireRow.Insert If IsEmpty(Target(-2)) Then L = Target(-1).Row Else L = Application.Max(6, Target(-1).End(xlUp).Row) With Target(0).EntireRow .Interior.ColorIndex = 4 .Interior.Pattern = xlSolid .Columns("B:C").Formula = "=SUM(B" & L & ":B" & Target(-1).Row & ")" .Cells(4).Value2 = "إجمالى اليوم " End With Application.ScreenUpdating = True Application.EnableEvents = True End If End If End If End Sub إدراج صف تلقائى - 1.xlsm

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

تفضل 2021 IN المشتريات.xlsx

السلام عليكم ورحمة الله تم إضافة بعض التسميات وأكواد في حدث الشيت... أرجو أن تفي الغرض المطلوب.... بن علية حاجي حضور.xlsm

بارك الله فيك وبالتوفيق ان شاء الله وفى انتظار الإصدار الجديد

بارك الله فيك استاذ عبد اللطيف وزادك الله من فضله

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

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

1- من الجهة اليسار حتحدد مكان الفولدر اللي انت حتعمل منه مصغرات و حتضغط على زر Add ________________________ 2- اذا تحب تغير تنسيق الصور حتضغط على الخيار هذا و تختار التنسيق اللي تحبه ________________________ 3- من الخيار هذا حتحدد فولدر جديد للمصغرات ________________________ 4- حتعلم بعلامة صح للخيار هذا عشان يفتح لك زر بجنبه اليمين و حتضغط عليه و حيفتح معاك نافذة زي اللي في الصورة الجاية 5 حتعلم على المربع Resize وحيفتح لك خيارات : اختار الخيار رقم 6 و روح للمربع رقم 7 و اختار الحجم اللي يعجبك ثم أوكي عند رقم 8 و حترجع للشاشة الأولى و اختار من الزاوية اليمين السفلية Convert عشان يبدأ التصغير ________________________ و حنرجع للسؤال الأهم / وين راح تستخدم المصغرات بالضبط ؟؟ أتمنى الشرح يكون مفهوم و بسيط و أي استفسار ثاني انا حاضر

اهلا وسهلا استاذي ابو بسملة الحقيقة الطريقة التي استخدمها تختلف قليلا عن هذه الطريق وان كانت تشترك معها في استخدام اكواد او وسوم xml الطريقة متعبة وتحتاج الى معرفة بهذة الوسوم او على الاقل المعرفة بلغة ترميز النصوص المتشعبة html الخاصة ببناء صفحات الانترنت لوجود تشابه بينهما طريقتي باختصار كتابة الوسوم ووضع id لكل امر اما طريقة تنفيذ الامر فعن طريق وحدة نمطية مع ان النتيجة رائعة الا ان الطريقة متعبة جدا وسوف احاول بعون الله ان اضع موضوع يشرح الطريقة واعتذر اذاكان الرد غير مفيد واستعير عبارة جميلة لاخي واستاذي الفاضل @essam rabea "انا راجل عجوز" فانا فعلا رجل عحوز والشروحات مرهقة جدا

وعليكم السلام-تفضل New Microsoft Excel Worksheet1.xlsx

تم تحرير كود لهذا الغرض Option Explicit Sub MY_Data_New() Application.ScreenUpdating = False Dim SH_from As Worksheet Dim T As Worksheet Dim rg_to_Patse As Range Dim Rt%, MY_max%, ro%: ro = 4 Set T = Sheets("Total") Set rg_to_Patse = T.Range("A3").CurrentRegion Rt = rg_to_Patse.Rows.Count If Rt > 1 Then Set rg_to_Patse = rg_to_Patse.Offset(1).Resize(Rt - 1) Else Set rg_to_Patse = T.Range("B4").Resize(, 5) End If rg_to_Patse.Clear For Each SH_from In Sheets If SH_from.Name <> T.Name Then MY_max = Application.Max(SH_from.Range("A:A")) SH_from.Cells(3, 1).Resize(MY_max, 6).Copy With T.Cells(ro, 1) .PasteSpecial (xlPasteValues) .PasteSpecial (xlPasteFormats) End With ro = ro + MY_max End If Next SH_from With T.Range("A4").Resize(ro - 4, 6) .Sort key1:=Range("b3"), Header:=1 .Value = .Value End With Application.ScreenUpdating = True arraNge_all End Sub '+++++++++++++++++++++++++++++++++++ Sub arraNge_all() Application.ScreenUpdating = False Dim nro% Dim MM% nro = Cells(Rows.Count, 1).End(3).Row Dim color_rg As Range For MM = 4 To nro If Range("a" & MM).Interior.ColorIndex <> xlNo Then If color_rg Is Nothing Then Set color_rg = Range("a" & MM).Resize(, 6) Else Set color_rg = Union(color_rg, Range("a" & MM).Resize(, 6)) End If End If Next color_rg.Copy Range("a" & nro + 1) color_rg.EntireRow.Delete Range("A4", Range("A3").End(4)).Formula = _ "=IF(B4="""","""",MAX($A$3:A3)+1)" Range("A3").CurrentRegion.Value = _ Range("A3").CurrentRegion.Value Range("A4").Select Set color_rg = Nothing Application.ScreenUpdating = True End Sub الملف من جديد M_data_new_SA.xlsm

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

المعادلة لا تستطيع ان تدرج اي تعليق او ان تقوم بتنسيق اي خلية او تغيير لونها... (هذا ليس من عمل المعادلات) فأنت لا تستطيع ان تقول للمعادلة اجعلي لي لون الخلية الفلانية احمر مثلاً حتى تستطيع MicroSoft ابتكار هكذا معادلات ما علينا سوى الصبر والانتظار أو عمل ذلك بواسطة الـــ vba

وعليكم السلام-اهلا بك فى المنتدى كيف تقول هذا فكل هذه برامج من المنتدى بدون كلمة مرور شوف بنفسك برنامج_مخازن_جديد.xlsm برنامج مخازن شامل .xlsm

تم علاج المشكلة كنت بدأت العمل علي ذلك لأني توقعت سؤالك عن ذلك في المساء ان شاء الله شاهد المرفق !_example_32.rar

الاستاذ القدير خالد سيسكو قدم الاجابة الصحيحة ومن باب اثراء الموضوع لقيمة خطأ في الحقل احيانا يكون لدينا حقل في النموذج الرئيسي يستمد قيمتة من خلال قيمة حقل غير منظم في النموذج الفرعي مثلا اجمالي المبيعات لفترة زمنية اكيد توجد اكثر من طريقة لاخذ القيمة ولكن الطريقة الاسهل [q_tax].[Form]![txt23] ولكن عندما لاتكون لدينا سجلات للفترة تكون قيمة الحقل في الرئيسي تساوى خطأ وللتغلب على ذلك يمكن استخدام دالة IsError لتكون بالشكل التالي =IIf(IsError([q_tax].[Form]![txt23]);0;[q_tax].[Form]![txt23]) والنتيجة تكون صفر

تمت الإضافة Hide.xlsm

1-لا تجعل الخلية L1 فارغة ولا تحتوي على اسم اي شيت 2-اذا كان النطاق من L2 و نزولاً فارغاً الكود يأخذ كل الصفحات وإلا الصفحات المحددة في هذا النطاق 3-عدم ترك خلايا فارغة بين اسماء الشيتات المطلوبة في العامود L تفضل الكود المطلوب Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim ACT_Ro% 'Actual row All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) Dim Mon_Array SH.Range("A4:F" & Rows.Count).Clear Set Principal = Sheets("serch") Mon_Array = Application.Transpose(Range("L2", Range("L1").End(4))) If UBound(Mon_Array) > Sheets.Count Then For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop Next_sh: Next Else '================================================ For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh1 If Application.CountIf(Principal.Range("L2:L50"), SH.Name) <> 0 Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh1 Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop End If Next_sh1: Next '==================================== End If If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:F" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Saerch_by_Special_sheets.xlsm

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

تم معالجة الامر بالتعديل على الكود كما يلي Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro%, m%: m = 4 Dim My_rg As Range SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("c:c").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row If Ro > 0 Then Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro, 1).Resize(, 5).Value m = m + 1 End If End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف من جديد Search_Account _new.xlsm

انا لم الاحظ اي شيء عشوائي

السلام عليكم - تسلم - جزيت خيرا غيرت بالكود ليناسب عملي وجعلت البحث على اساس خلية A بدل C ولكن توجد مشكلة بالقائمة المنسدلة - مرة تعمل ومرة لا تعمل

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

طباعة الشهادات بطريقة اختيار الفصل للاستاذ الكبير الصقر جزاه الله كل خير طباعة شهادات فصل.rar

ان شاء الله سيكون لي نصيب من الخير سأرفق كود رائع لعمل اللجان والكود خاص بالعلامه عبد الله باقشير كشف مناداة بالكود.rar

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

شكرا جزيلا هل يمكن تجميع هذه الأعمال في ملف واحد

هذا المثال يوضح كيفية منع ادخال قيمة أكبر من صفر فى حقل رقمي اسمه App1 و ذلك فى حال كون هناك قيمة أكبر من صفر سبق تسجيلها فى هذا الحقل و ذلك لنفس التاريخ و الذي يتم تسجيله فى حقل mdate فيتم اختبار القيم فى الجدول التي لها نفس التاريخ و اذا كان هناك سجل لنفس التاريخ لديه قيمة أكبر من صفر لنفس الحقل فنمنع التسجيل - , و هذا يتم باستخدام الدالة Dcount كما نمنع تسجيل أي قيمة أكبر من صفر للحقل فى حال عدم تسجيل التاريخ فى حقل التاريخ اولا ا ChechOtherFields.rar