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

السلام عليكم 🙂 . جعفر

كل عام وجميع الاخوة بالمنتدى بالف خير من الجميل ان نبدأ العام بتهنئة بكود اكسس تحياتي للجميع test.rar

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

وعليكم السلام-لك ما طلبت موازنة علي البنود لكل مشروع.xlsx

تفضل يا سيدي بعد اذن الاستاذ حسين طبعاً و بدون الاكواد ومشاكلها (الاكسل يمنع كذلك ادخال اي شي غير الارقام في النطاق من A1 الى A5 )) VERIFICATION.xlsx

تفضل >>>>>>> __برنامج المراجعة النهائية - نسخة.rar

اللهم قد أقبل علينا عام جديد نسألك الخير كله عاجله وأجله ونعوذ بك من شره كله عاجله وأجله، ونسألك اللهم عملا يقربنى إليك يا ذا الجلال والإكرام وصل الله على سيدنا محمد وعلى آله وصحبه وسلم

السلام عليكم تم التعديل على أمر البحث في كود اليوزرفورم (حسب ما أعرف)، وذلك بتغيير الأمر: Me.TextBox4.Value = Application.WorksheetFunction.VLookup(Val(Me.TextFind.Value), ss, 2, False) بالأمر: Me.TextBox4.Value = Application.WorksheetFunction.VLookup(IIf(IsNumeric(Me.TextFind.Value), Val(Me.TextFind.Value), Me.TextFind.Value), ss, 2, False) المصنف3.xlsm

جرب هذا الماكرو (كان من الافضل عدم وجود خلايا مدمجة) تم تبديل اسم الصفحة الثانية الى اسم بالاجنبية MY_DATA Sub Copy_With_Merged_Cells() Const My_step = 26 Dim M As Worksheet, S As Worksheet Dim I%, Ls%, x%, t% Dim MX%, R% Set M = Sheets("MY_DATA") Set S = Sheets("Sheet1") MX = Application.Max(M.Range("A:A")) Ls = S.Cells(Rows.Count, 1).End(3).Row: Ls = Ls + 1 R = M.Range("A:A").Find(MX, LookAt:=1).Row For I = 12 To R Step My_step M.Range("B" & I).Resize(19) = "" Next For I = 1 To Ls Step 20 t = My_step * x + 12 S.Range("A" & I).Resize(20).Copy M.Range("B" & t) x = x + 1 Next M.Columns(2).AutoFit End Sub الملف مرفق Copy_For_Me.xlsm

بارك الله فيك أستاذنا الفاضل سليم ولكن بعد إذنك أقترح أن تكون المعالة =AND(ISNUMBER(A1);SUM($A$1:$A$5)<=20) حتى إذا تم تغيير الأرقام الأولى بعذ ذلك فيظل التحقق من الصحة يعمل أستاذ حسين مامون بارك الله فيك ولكن بعد إذنك من الأفضل أن يوضع الكود في حدث Worksheet_Change لأن في حدث Worksheet_SelectionChange ممكن يقبل أي رقم زائد ولا يعطي الرسالة إلا بعد تحديده VERIFICATION.xlsx

وضعت كود في حدث الشيت جرب لعله ما تريد التحقق من صحة الحل.xlsm

جرب التعديل المستخدم asd كلمة السر 123 login __ (1).xlsm

كل عام وانتم الى الله اقرب تحياتي

وعليكم السلام ورحمة الله وبركاته نعم اخي الكريم كلمة Set من الكلمات المحجوزة في access وهناك الكثير ايضاً محجوز مثل add , all , and ... الخ وعند استخدام هذه الكلمات كإسم حقل او اسم جدول يحدث تعارض في الاوامر كما حدث معك تماماً تحياتي

جرب الملف التالي Annual_Repport.xls

شكرا جزيلا ، هدية جميلة 🙂 جعفر

اللهم إنا نسألك خيرها و نعوذ بك من شرها

أستاذ حسين مامون بارك الله فيك ولك بمثل ما دعوت

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

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

اللهم صلي على محمد وآل محمد تحية طيبة مباركة بالافراح والخير على اعضاء المنتدى الكرام 🌹0🌹2🌹0🌹2🌹👉 انشاء الله يكون هذا العام الجديد خير وبركة وصحة وعافية على بلادي العراق وعلى جميع البلدان العربية بالخير والسلام يا رب 🤲

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

كل عام وانتم جميعا بخير 🌺🌺

أستاذ يوسفي أين الضغط على الإعجاب ؟!💙

استبدل هذا السطر image_path = Application.GetOpenFilename(FileFilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select A File", MultiSelect:=False)

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

يارب تكون سنة كلها خير على الجميع اه ثم اه ما بداخل البطيخة (الحبحب) استاذنا / @jjafferr

شاهد المرفق !_Omar_3.rar

كلامك صحيح أخي ابو البشر ...... ليس لعدد صفحات ملف الاكسل تأثير ..... جرب في جهاز آخر وأعلمنا بالنتيجة !!!!!

المطلوب غير واضح أحد عناصر الفورم ( ناقص ) محاولة مني على حسب فهمي تفضل لعله يفي الغرض نسخة المرسلة في المنتدى الخاصة بالصندوق.xls

تفضل انظر المرفق <<<<<<<<< ولاحظ سحب البيانات من خلال البرنامج في جدول باسم نسخة ( طبعا انا نسختها حتى تشوف النتيجة ... لأن المشكلة من جهازك في عدم ظهور اسم الشعبة والمادة ) جرب المرفق لربما زالت تلم المشكله ,,,,, ‏‏Database.mdb

؟؟؟

افتح محرر الاكواد وانظر المكتبة الموجودة في الصورة هل هي مؤشر عليها صح ....

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

جرب الملف المرفق واعلمني بالنتيجة ....... ‏‏Database1 (3).rar بالنسبة لحقل الشعبة والمادة ( قم بتغيير اسم الملف عندك من ‏‏Database الى اي اسم اخر مثلا ‏‏Database1 )

أستاذ ابومهندالخضري أين الضغط على الإعجاب ؟! 💙

أستاذ ابومهندالخضري لا اعلم لماذا لا تقوم بالضغط على الإعجاب على الرغم ان كل الإجابات ممتازة ؟!!!! 💙

لا لزوم للحلقات التكراري في هذه الجالة يكفي هذا الكود البسيط Sub Fill_Empty() Range("B2:F6").SpecialCells(4) = "/" End Sub

ضع هذا الكود في حدث thisworkbook Option Explicit Private Sub Workbook_Open() On Error Resume Next Dim x, r Dim ws As Worksheet Set ws = Sheets("ورقة1") For x = 2 To 6 For r = 2 To 6 If ws.Cells(x, r) = "" Then ws.Cells(x, r) = "/" End If Next Next End Sub وهذا في حدث الشيت Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim rng Set rng = Range("b2:f6") If Not Intersect(Target, rng) Is Nothing Then If Target = "" Then Target = "/" End If End Sub

استعمل هذا الكود في حدث الشيت Private Sub Worksheet_Change(ByVal Target As Range) Dim rng Set rng = Range("b2:f6") If Not Intersect(Target, rng) Is Nothing Then If Target = "" Then Target = "/" End If End Sub

عندها يلزم هذا الكود Dim cel As Range Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("B1:D20")) Is Nothing _ And Target.Count = 1 Then Range("B1:D20").Interior.ColorIndex = 6 For Each cel In Range("B1:D20") If cel < 0 Then cel.Interior.ColorIndex = 50 Next Else Application.EnableEvents = True: Exit Sub End If If Not IsNumeric(Target) Or Target < O Then Target.Interior.ColorIndex = 50 Target.Select MsgBox "خطأ" & Chr(10) & _ "مسموح فقط بأعداد اكبر من صفر", 16, _ vbMsgBoxRight End If Application.EnableEvents = True End Sub الملف من جديد MY_NEW_CODE.xlsm

هذا معناه ان البرنامج معمول على وندوز ليس عربي !! فما هي اللغة اللي كان عليها الكمبيوتر لما عملت البرنامج؟ هل هناك حروف اجنبية (مو انجليزية) في البرنامج ؟ اعمل التالي: اعمل بملف اكسس جديد ، 1. استورد جميع الكائنات من الملف القديم ، وشغل البرنامج ، اذا اشتغل بدون مشاكل ، فقد تم حل المشكلة 🙂 وإلا ، اعمل بملف اكسس جديد ، 2. استورد الجداول فقط من الملف القديم ، وشغل البرنامج ، اذا اشتغل بدون مشاكل: ثم استورد الاستعلامات فقط من الملف القديم (طبعا الجداول ستكون موجودة) ، وشغل البرنامج ، اذا اشتغل بدون مشاكل: ثم استورد نموذج واحد فقط من الملف القديم ، وشغل البرنامج ، اذا اشتغل بدون مشاكل: تابع في استيراد النماذج والتقارير ، واحدا واحد ، الى ان تعرف النموذج/التقرير اليي فيه المشكلة ، فيجب عليك ان تعيد صنعه مرة ثانية. جعفر

جرب هذا الملف الذي لا يسمح لك بكتابة ع اكثر من المطلوب في الخلية C Dawam.xlsx

عليك السلام ورحمة الله وبركاته جرب هذا دوام الموظفين.xlsx

الاخ Mahmoud Atef بخصوص هذا الطلب : من الصعب جدا عمل ذلك لأن القوائم المنسدلة تحتوي علي خلايا مدمجة ماتم تنفيذه 1- جميع امدية القوائم اصبحت دياميكية اي عند اضافة اي بنود جديدة لأي قائمة سوف تظهر بها ولذلك تم استبدال المسافة بين اسماء الشتات بالشرطة السفلية ( _ ) 2 -زر الطباعة يقوم بالمعاينة قبل تنفيذ امر الطباعة 3 - تم تعديل امر ( Save ) ليكون اتجاه الشيت في سياق الملف من اليسار الي اليمين اما بخصوص هذا الطلب صحح لي فهمي لهذا الطلب سيتم وضع صورتين في الجزئين المدمجين وتتم طباعتهم في صفحة تالية للشكوي عند اختيار امر ( Attach ) شاهد المرفق Complaints_new edit_2.rar

جرب هذا الكود وهو نفس الكود في ملفك وبواسطة AND يمكن اضافة اكثر من جهاز Private Sub Workbook_Open() 'If Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("C:").SerialNumber) <> "سريل الجاهز الاول" And Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("C:").SerialNumber) <> "سريل الجهاز الثاني" Then 'MsgBox "Attention ! Ce programme est spécial pour M : tahar1983 ", vbCritical, "Violation des droits du programme" 'ThisWorkbook.Close savechanges = True 'End If End Sub حماية برقم الهارد ديسك.xls وجدت الكود في ملفاتي ويعمل على خمسة اجهزة ويمكن زيادتها الى ما تشاء Private Sub Workbook_Open() 'Dim PC1$, PC2$, PC3$, PC4$, PC5$ 'PC1 = "74828D32" ' رقم الايدي للجهاز 1 'PC2 = "12BE1EE2" ' رقم الايدي للجهاز 2 'PC3 = "2D4F902" ' رقم الايدي للجهاز 3 'PC4 = "282B91B1" ' رقم الجهاز 4 'PC5 = "" ' رقم الايدي للجهاز 5 'With CreateObject("Scripting.FileSystemObject") 'If Hex(.Drives.Item("c:").SerialNumber) = PC1 Or Hex(.Drives.Item("c:").SerialNumber) = PC2 _ 'Or Hex(.Drives.Item("c:").SerialNumber) = PC3 Or Hex(.Drives.Item("c:").SerialNumber) = PC4 _ 'Or Hex(.Drives.Item("c:").SerialNumber) = PC5 Then 'Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر " 'ThisWorkbook.Close SaveChanges = True 'End If 'End With End Sub

تفضل فقط يمكنك استخدام معادلة المصفوفة هذه =IF(ROWS($K$4:K4)<=SUMPRODUCT(--(COUNTIF($I$4:$I$140,$D$4:$D$150)<>1)),INDEX($D$4:$D$150,SMALL(IF(COUNTIF($I$4:$I$140,$D$4:$D$150)<>1,ROW($D$4:$D$150)-ROW($D$4)+1),ROWS($K$4:K4))),"") Etat de developpement de solde.xlsx

السلام عليكم تفضل اخي الفاضل test1.xlsx