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

ما ذكرة أخي @kha9009lid صحيح لكن جرب هذا المرفق لربما يخرجك من مأزق 2 مليون اسم مكرر مثال (5).accdb

السلام عليكم ورحمة الله تم وضع التنسيق الشرطي حسب ما تريد في خلايا العمود (العمود المعني)... New (2).xlsx

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

بسم الله الرحمان الرحيم و الصلاة و السلام على أشرف المرسلين أما بعد: سوف نقوم اليوم إن شاء الله بشرح أداة WebBrowser وأهم ما يتعلق بها من أوامر و أحداث و خصائص و إدخال و إخراج. و سوف يتم تقسيم هذا العمل إلى مجموعة حلقات نبدأ من الصفر حتى آخر نقطة نستطيع الوصول إليها إن شاء الله مع وضع مثال تطبيقي لكل حلقة. مقدمة: WebBrowser هي أداة تعمل عمل أي متصفح و هي مقترنة المتصفح الشهير Internet Explorer فهي تساعدك في تصفح المواقع من ناحية و التحكم في أكواد HTML وكل ما يرتبط بها من إدخال و استخراج بيانات من ناحية أخرى. ملاحظة: لتشغيل هذه الأداة بشكل جيد يجب تحديث المتصفح الشهير Internet Explorer إلى الإصدار 10 أو 11. مع العلم أن ونداوز 10 به الإصدار 11 الحلقة الأولى: أكواد التصفح سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من التصفح و التنقل داخل الأداة. 1- كود فتح صفحة موقع: WebBrowser3 هو اسم الأداة داخل النموذج Me.WebBrowser3.Navigate ("رابط الصفحة كامل") 2- كود فتح صفحة فارغة: Me.WebBrowser3.Navigate ("about:blank") 3- كود الرجوع للصفحة السابقة: Me.WebBrowser3.GoBack 4- كود الإنتقال للصفحة التالية: Me.WebBrowser3.GoForward 5- كود إعادة تحميل الصفحة: Me.WebBrowser3.Refresh 6- كود إيقاف تحميل الصفحة: Me.WebBrowser3.Stop 7- كود إستخراج رابط الصفحة الحالية: MsgBox Me.WebBrowser3.Document.url و هذا مثال لما تم ذكره في هذه الحلقة webbroser.rar

الحلقة الثانية: أكواد الطباعة و الخصائص و... سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من طباعة صفحة الويب و حفظها و عرض خصائص الصفحة و غيرها... 1- كود طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT 2- كود معاينة طباعة الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT 3- كود عرض خصائص الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT 4- كود حفظ صفحة الويب: Me.WebBrowser3.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT 5- كود تنسيق الصفحة: Me.WebBrowser3.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT 6- كود عنوان رابط الصفحة: MsgBox Me.WebBrowser3.LocationName 7- كود رابط الصفحة: MsgBox Me.WebBrowser3.LocationURL 8- كود فتح الصفحة الإفتراضية للمتصفح: Me.WebBrowser3.GoHome 9- كود فتح صفحة البحث: Me.WebBrowser3.GoSearch 10- كود فتح صندوق التصفح: هذا الكود يقوم بفتح صندوق لإدخال رابط صفحة ويب جديدة Me.WebBrowser3.ExecWB OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT 11- كود تخطي رسائل الأخطاء التي تظهر من الأداة عند التصفح: Me.WebBrowser3.Silent = True وهذا المرفق بعد الإضافات الجديدة webbroser.rar

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

الاخ smfsho2009 شاهد المرفق Test_1.xls

اهلا بك فى المنتدى-تفضل تم عمل المطلوب بهذا الكود Sub ØÈÇÚÉ1() Sheets("استمارة متابعة").Activate Range("H2").Activate [H2] = 1 ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 1 ActiveWindow.SelectedSheets.PrintOut Loop While ActiveCell.Value <= Range("x2").Value Range("H2").Activate [H2] = 1 End Sub طباعة كل الأسماء.xlsm

جزاك الله خير اخي احمد دكتور محمد جزاك الله خير اخي الفاضل فقد كافأت واحسنت الجزاء قَالَ رَسُولُ اللَّهِ صَلَّى اللَّهُ عَلَيْهِ وَسَلَّمَ : ( مَنْ صُنِعَ إِلَيْهِ مَعْرُوفٌ فَقَالَ لِفَاعِلِهِ : جَزَاكَ اللَّهُ خَيْرًا فَقَدْ أَبْلَغَ فِي الثَّنَاءِ ) تقبل من اخيك كل الود والتقدير منكم نستفيذ استاذنا جعفر ومنكم نتعلم قبل الاكواد والحلول الجميلة نتعلم التواضع وحسن الخلق اسأل الله ان يكون ما تقدمه في ميزان اعمالك اخي @أحمد الفلاحجى اعجبني مثالك واسمح لى بتعديل بسيط ليكون التحديد والالغاء بامر واحد DoCmd.SetWarnings False If Me.NAll.Caption = "no" Then DoCmd.RunSQL "UPDATE table1 SET table1.[yesNo] = 0;" Me.Requery Me.NAll.Caption = "yes" ElseIf Me.NAll.Caption = "yes" Then DoCmd.RunSQL "UPDATE table1 SET table1.[yesNo] = -1;" Me.Requery Me.NAll.Caption = "no" DoCmd.SetWarnings True End If ولتبسيط الامر نقول اذا كان زر الامر باسم no نفذ استعلام بجعل قيمة خانة الاختيار غير محددة ثم حدث وغير اسم زرالامر الى yes واذا كان زر الامر باسم yes نفذ استعلام لتغيير قيمة خانة الاختيار الى محدد ثم حدث واعد تسمية زر الامر الى no yn.accdb

السلام عليكم تفضل اخي الكريم =DLookup("[Balance]"; "[Query1]"; "[barcode] =" & farey2!barcode) balacne on form.rar تحياتي

لا لزوم للكود ولا لليوزر في هذه الحالة شاهد هذا الملف COND_FORMAT.xlsm

جربي المرفق Test1.accdb DoCmd.SetWarnings False If [خيار12] = True Then DoCmd.RunSQL "UPDATE table1 SET table1.yesno = yes " Me.Requery Else DoCmd.RunSQL "UPDATE table1 SET table1.yesno = no " Me.Requery End If DoCmd.SetWarnings True

ربما هذا هو المطلوب fayz.rar

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

السلام عليكم 🙂 هناك الكثير من الميزات/الاوامر التي يعطينا برنامج الاكسس ، والتي يمكن ان نعمل لها بديل ، ولكن يكون هناك فرق في سرعة تنفيذ كودنا مقارنة مع الكود الاصل من الاكسس !! مثل القائمة المختصرة التي تظهر لنا بالنقر على زر الفأرة الايمن ، والتي بها يمكننا ان نستغني عن الكثير الاوامر ، مثل الفرز والتصفية بأنواعه ، ولكن وللأسف الشديد ، فأنا ارى ان 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

طريقة استخدمها في برامجي اتمنى لكم الفائدة officna_salloum.accdb

اعد التحميل Test_1.xlsm Test_2.xlsm

بعد اذن الاخ علي نظرة على هذا الملف Max_min.xlsx

الحمدلله 🙂 وشكرا على المعلومة 🙂 جعفر

تفضل تم الحل من قبل أستاذنا الكبير حسين مأمون له منا كل المحبة والإحترام User.xlsm

عفوا ، انا لم افهم شيء !!

اعد التحميل الملف الاول تم استخدام عناصر تحكم النموذج بدلا من استخدام عناصر تحكم ActiveX الملف الثاني لم ينم الانشاء من عناصر تحكم النموذج او عناصر تحكم ActiveX بل تم انشاء الفرام والزر بأستخدام Crate Object.Controls عن طريق انشائهم بواسطة Module وبمساعدة Class كود Module1 Dim objButtons(1 To 1) As New Class1 Sub Add_Frame() With ActiveSheet.OLEObjects .Delete With .Add(ClassType:="Forms.Frame.1", Link:=False, DisplayAsIcon:=False) .Name = "Frame1" .Left = 400 .Top = 75 .Width = 200 .Height = 75 With .Object.Controls.Add("Forms.CommandButton.1", "cmdButton1", True) .Caption = "OK" .Left = 5 .Top = 5 .Width = 75 .Height = 30 End With End With End With Application.OnTime Now, "SetOnAction" ' End Sub Private Sub SetOnAction() ' Dim x As Control For Each x In ActiveSheet.OLEObjects(1).Object.Controls If TypeOf x Is MSForms.CommandButton Then i = i + 1 Set objButtons(i).CmdBtn = x End If Next On Error Resume Next If ActiveWorkbook.Sheets.Count = 1 Then Application.DisplayAlerts = False ActiveWorkbook.Sheets.Add.Delete Application.DisplayAlerts = True Else With ActiveSheet .Next.Activate .Activate End With End If ' End Sub كود Class1 Public WithEvents CmdBtn As MSForms.CommandButton Private Sub CmdBtn_Click() ' Select Case Me.CmdBtn.Caption Case "Ok" Case Else MsgBox "Hello" End Select ' End Sub مع استخدام حدث Workbook_Open لعمل اضافة الفرام والزر عند فتح الملف ولا توجد طريقة لأستخدام Frame سوي هاتين الططريقتين Private Sub Workbook_Open() ' Add_Frame ' End Sub ومن الاسهل لك لتطويع الكود الطريقة الاولي بملف Test_1 Test_1.xlsb Test_2.xlsb

بارك الله فيك أستاذ جعفر هذه هى النتيجة آخر 3 تقارير لكل موظف و هذا هو ال sql SELECT qq1.TaqEmp, qq1.taqFrom, qq1.taqTo, qq1.taq_number FROM qq1 WHERE (((qq1.taqFrom) In (SELECT TOP 3 ss.taqFrom FROM qq1 AS ss where ss.taqemp = qq1.taqemp ORDER BY ss.taqFrom DESC; ))) ORDER BY qq1.TaqEmp, qq1.taqFrom DESC;

طريقة احترافية اخي @jjafferr بارك الله فيك .... دائما نستفيد منك

وعليكم السلام تم عمل المطلوب برقم السيارة عباد الرحمن 12020.xlsm

وعليكم السلام اخوي محمد 🙂 اذا ممكن ومن بيانات المرفق اعلاه ، ان تعمل لنا الجواب في ملف اكسل او وورد ، مثال او مثالين لوسمحت ، حتى يتضح المطلوب 🙂 جعفر

اسمحوا لي ان اشرح فائدة الطريقة اللي اشرت لها انا 🙂 الفائدة هي محاكاة البرنامج الاخر ، وارسال بيانات له ، واستيراد بيانات منه ، وهذا لا يقتصر على قاعدة البيانات التي فتحت البرنامج الآخر ، وانما يعتمد على اي عدد من قواعد البيانات التي فتحتها عن طريق المتغير appAccess و appAccess2 و ... وبعد اذن اخي ابو البشر ، فاستخدمت مرفقه ، وبتعديل بسيط على البرنامج Sub بحيث النموذج mark2 لا يُفتح تلقائيا ، واضفت له زر : الكود التالي : يفتح قاعدة البيانات Sub ، 1. يرسل القيمة "c:\abc\abc" الى الحقل txtPath ، 2. ويأخذ المسمى الموجود في حقل التسمية 7 ، ويضعه في برنامجنا : Private Sub cmd_View_Kids_info_Click() On Error GoTo err_cmd_View_Kids_info_Click Dim appAccess As Object Dim DB_Path As String Dim myWhere As String 'if the Remote Application/Form is open, close it first appAccess.DoCmd.Quit 'now open the Form for the new Employee_ID Set appAccess = CreateObject("Access.Application") DB_Path = Application.CurrentProject.Path & "\mark2.mdb" appAccess.OpenCurrentDatabase (DB_Path) appAccess.DoCmd.OpenForm "Mark" appAccess.Visible = True With appAccess.Forms!Mark .txtPath = "c:\abc\abc" Me.lbl2.Caption = .[تسمية7].Caption End With appAccess.UserControl = True 'Set appAccess = Nothing Exit_cmd_View_Kids_info_Click: Exit Sub err_cmd_View_Kids_info_Click: If Err.Number = 91 Or Err.Number = 462 Then 'the application is NOT open, ignore the error Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر fayz.zip

السلام عليكم 🙂 وهذا من قديم الصوف 🙂 جعفر

تفضل سؤال وجواب2.xlsm

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تحياتي

وعليك السلام ورحمة الله وبركاته قم بوضع هذه الأسطر أسفل كود الترحيل قبل End Sub ActiveWorkbook.Save With ActiveSheet.PrintOut End With

جرب المرفق DoCmd.RunSQL "DELETE * FROM table1 WHERE key NOT IN ( SELECT min(key) FROM table1 GROUP BY FirstName, Address2)" حذف السجلات المكررة.mdb

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

من خصائص الحقل كما في الصورة :

اتفضلى محاوله منى على قدى بس عملتها عن طريق زر اضفت زرين واحد لوضع العلامه وواحد للالغاء بالتوفيق yn.accdb

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

استعمل TOP 3 بدلا عن TOP 1 جعفر

السلام عليكم 🙂 اليك هذا المرفق ، فيه مثالين: المثال الاول: عندنا جدولين ، tbl_Seq و tbl_New_Seq ، فيهم نفس البيانات ، نريد نأخذ اكبر قيمة من الحقل Seq في tbl_Seq ، ثم نستخدم هذه القيمة ، وندخل بقية البيانات في الجدول tbl_New_Seq ، المثال الثاني: نفس المثال الاول ، ولكن العمل على جدول واحد فقط ، tbl_Sections . المشكلة في لما تستعمل استعلام المجاميع ، والامر Max للحقل Seq ، لتحصل على اعلى قيمة ، ثم تربطه بالجدول الآخر ، فيصبح استعلامك (نموذجك) غير قابل للتعديل ، بينما اذا استعملنا نفس استعلام المجاميع اعلاه ، بالامر Max للحقل Seq ، ولكن استعملناه كإستعلام فرعي ، فيصبح الاستعلام (النموذج) قابل للتعديل 🙂 اترك لك المجال تفحص المثال الاول ونتائجه ، وهنا اوضح عمل المثال الثاني: فنرى اني عملت استعلام فرعي للقيمة Seq : . ونتيجة الاستعلام ، يمكن تعديلها ، للحقل New_Section : . وللتجربة ، اخذ الاستعلام الفرعي اعلاه ، وضعه في استعلام مستقل ، ثم اربط الاستعلام بالجدول ، فلن تحصل على نتيجة صحيحة !! جعفر 1167.SubQuery.mdb.zip

شكرا لك أستاذ kha9009lid وشكرا للاستاذ محمد ابوعبد الله على كل ماقمتم به أرجو أن يكون في ميزان حسناتكم test(5).accdb

جرب هذا الكود تم تغيير اسماء الشيتات الى اللغة الاجنبية لسهولة التعامل مع الكود من حيث النسخ واللصق Option Explicit Private Sub Worksheet_Activate() FIL_CDATA_VAL End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub FIL_CDATA_VAL() Dim i As Long: i = 8 Dim DIC As Object Set DIC = CreateObject("Scripting.Dictionary") Do Until Sheets("DATA").Range("C" & i) = vbNullString DIC(Sheets("DATA").Range("C" & i).Value) = "" i = i + 1 Loop With Sheets("RESULT").Range("k5").Validation .Delete .Add 3, Formula1:=Join(DIC.KEYS, ",") End With Set DIC = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++ Sub GET_CERTIFICAT() Dim dat As Worksheet, RES As Worksheet Dim Num%, k%, R, i%, Found_Ro%, Ro%: Ro = 8 Dim FOUND_RG As Range Dim n: n = 3 Dim arr Set dat = Sheets("DATA"): Set RES = Sheets("RESULT") Union(RES.Range("c5"), RES.Range("c19"), RES.Range("c33")) = vbNullString Union(RES.Range("c8:k9"), RES.Range("c22:k23"), RES.Range("c36:k37")) = vbNullString Num = RES.Range("K5") arr = Array(2, 5, 7, 9, 11, 13, 15, 17, 19, 21) For k = 1 To n Set FOUND_RG = dat.Range("a8").CurrentRegion.Columns(3). _ Find(Num, LOOKAT:=1) If FOUND_RG Is Nothing Then Exit Sub R = FOUND_RG.Row RES.Cells(Ro - 3, 3) = dat.Cells(R, arr(0)) For i = 1 To UBound(arr) With RES.Cells(Ro, 3).Offset(, i - 1) .Value = dat.Cells(R, arr(i)) .Offset(1) = dat.Cells(R, arr(i) + 1) End With Next RES.Cells(Ro + 2, 3) = dat.Cells(R, 23) Num = Num + 1: Ro = Ro + 14 Next End Sub الملف مرفق RESULT.xlsm

تفضل >>>>> MARK.mdb

جرب هذا الملف الكود يعمل في النطاق من A1 الى A10 (اللون الأصفر) الكود Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A1:A10")) Is Nothing _ And Target.Count = 1 Then Range("B1:B10").ClearContents Target.Offset(, 1) = Range("F1") End If Application.EnableEvents = True End Sub الملف مرفق Writ in Offset.xlsm

السلام عليكم أستاذ جعفر موضوع في قمة الروعة ملاحظة صغيرة في الكود الموضوع بالأعلى : هناك بعض المتغيرات غير مصرح بها مع أنها موجودة في المرفق لكن من يريد تطبيق الكود بشكل مباشر من المشاركة سوف يظهر له خطأ. Public Const msoBarPopup = 5 Public Const msoControlButton = 1 Public Const msoControlEdit = 2 Public Const msoControlComboBox = 4 Public Const msoButtonUp = 0 Public Const msoButtonDown = -1 أخيرا لي الشرف العظيم أن أقوم بتثبيت هذا الموضوع

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

عليك السلام ورحمة الله وبركاته بالنسبة للمطلوب الأول جرب هذا لعله يفي الغرض jour.xlsm

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

السلام عليكم و رحمة الله تعالى و بركاته. أستأذنك أستاذ القدير جعفر في إضافة تعديل بسيط على الكود الذي قمت بتقديمة. الكود الذي كتبته أستاذي يقوم بتحديد الخانة الغير محددة و نزع التحديد عن الخانة محددة لقد أضفت تعديل بسيط ليقوم الكود بتحديد كامل الخانات أو إزالة التحديد من جميع الخانات كما طلب السائل. Dim f As String Dim rst As DAO.Recordset Set rst = Me.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount f = rst!done For i = 1 To RC If f = "true" Then rst.Edit rst!done = False rst.Update Else rst.Edit rst!done = True rst.Update End If rst.MoveNext Next i rst.Close: Set rst = Nothing Selection.rar

وعليكم السلام تفضل Private Sub cmd_Select_All_Click() '1 ' Dim rst As DAO.Recordset ' Set rst = Me.RecordsetClone ' rst.MoveLast: rst.MoveFirst ' RC = rst.RecordCount ' ' For i = 1 To RC ' rst.Edit ' rst!done = Not rst!done ' rst.Update ' ' rst.MoveNext ' Next i ' ' rst.Close: Set rst = Nothing '2 CurrentDb.Execute ("UPDATE fatora SET done =" & Not Me.done) Me.Requery End Sub . جعفر

السبب الذي قلت ان جدولك ليس صحيحا لقاعدة البيانات ، هو انك يجب ان تضيف حقل جديد كل شهر ، فالطريقة الصحيحة لعمل الجداول هو اضافة سجلات وليس اضافة حقول وهناك مثل مشهور في قواعد البيانات يقول : الحقول غالية والسجلات رخيصة اما اذا تريد تمشي حالك الان بالجدول الموجود ، ومجرد تريد ان تجمع قيم جميع الحقول ، اعمل استعلام فيه جميع الاسماء ، وننادي منه الدالة Add_Salaries والتي عملناها في الوحدة النمطية ، ونرسل معها اسم الشخص: . وهذا كود الدالة Add_Salaries: Function Add_Salaries(F As String) As Double 'F = Full Name Dim rst As DAO.Recordset Dim fld As Field 'get this Name Record from the table Set rst = CurrentDb.OpenRecordset("Select * From [salary2015+2014] Where Full_Name='" & F & "'") T = 0 'initial Total 'loop through the fields For Each fld In rst.Fields 'Debug.Print fld.Name & vbTab & fld.Value 'skip the Full_Name field name If fld.Name <> "Full_Name" Then 'add the field values T = T + fld.Value End If Next fld 'now send this Total to the query Add_Salaries = T End Function . حيث اننا في الدالة نطلب سجل الشخص من الجدول salary2015+2014 ، ثم نقول بقراءة الحقول وجمعها ، زنرسل النتيجة الى الاستعلام ، فتصبح نتيجة الاستعلام: . جعفر 262.salary2015+2014.accdb.zip

وعليكم السلام هناك طريقة افضل لحفظ سجلاتك في الجدول ، فطريقتك مأخوذة من الاكسل مثلا ، وليست صحيحة لقواعد البيانات . عملت لك جدول جديد ، وجلبت لك البيانات اليه: . والبيانات: . وعليه ، عملت عدد 2 استعلام جدولي ، واحد شامل لكل السنوات: . ونتائجه: . واستعلام سنوي (يعني استخدم خاصية التصفية) ، لكل سنة على حدة: . والنتيجة: . جعفر 262.salary2015+2014.accdb.zip