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

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


Popular Content

Showing content with the highest reputation since 22 مار, 2020 in all areas

  1. 10 points
    قبل فتح التطبيق يتم فقط اضافة ملفات لتنسيقات الصوت والفيديو المختلفة داخل المجلد المرفق باسم sound files يا عينى ع الدلع او بعد فتح التطبيق يتم الضغط على زر الأمر تحديث المكتبة القسم الايمن من الشاشة هو التحكم فى مشغل الوسائط برنامج الميديا بلاير الجزء الاوسط هو التنقل بين الاذاعة الصوتية وتعمل اون لاين او مكتبة ملفاتك من المجلد Sound files واسفل قائمة التشغيل التى تحتوى على الملفات خصائص واعدادات التشغيل والتكرار حاجه دلع الجزء الايسر وهو خاص بالتحكم فى الصوت لجهاز الحاسوب بس خلاص اسف انا باتصفح من الجوال مش قادر اعمل تنسيق للموضوع اكتر من كده ولا عارف ارفق صور فى انتظار ردكم بعد التجربة وفى الختام اتوجه بكل الشكر والتقدير والعرفان بالجميل لكل اساتذتى جميعا واخوانى فى هذا الصرح الشامخ الذين اتعلم منهم دائما وابدا اخص بالشكر الاستاذ القدير @jjafferr 🌹 حيث اننى دمجت بهذا المرفق الكثير مما قدمه من أفكار وتوجيهات عبر اشهر وسنوات وكذلك الاستاذ القدير @ابوخليل 🌹 كذلك استخدمت هنا الكثير من الاكواد التى تعلمتها منه عبر اشهر سنوات وباقى كوكبة اساتذتى الفضلاء واخوانى كل الشكر لكم 🌹🌹🌹 Digital Player App.zip
  2. 6 points
    لم اطلع على المرفق ولكني عملت لك هذا حسب ما فهمت Dim i As Integer Private Sub ID_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 13 Then i = i + 1 If i = 3 Then MsgBox "اعمل الإجراء" Exit Sub End If Else i = 0 End If End Sub test1.mdb
  3. 5 points
    السلام عليكم 🙂 الاستعلام الذي عملته انت : . بدون ربط بين الجداول ، وهذا معناه ، انك تطلب سجلات عددها : 16x8x11x16x27x24x10x6 = 875,888,640 (شوف صورة سجلات الجداول في الاسفل ، علشان تعرف من وين جئت بهذه الارقام 🙂 ) ، فهل سرعة محرك كمبيوترك CPU ، وكمية الذاكرة المؤقته RAM ، قادرة على عرض هذا الكم الهائل من السجلات 🙂 . خلينا نشوف استعلام علشان نفهم الموضوع : نخلي الجدولين فقط ، والي نعرف ان مجموع عدد السجلات سيكون : 16x8 = 128 . والنتيجة ، وكما يعرضها الاستعلام : . وهذا اللي عملنه انا بإستعمال مرفقك ، وهي الطريقة الافضل لبرنامجك : . ولكن ، هذه طريقة الاكسل في وضع البيانات ، بينما اذا اردنا تعديل الاكسس ، فيكون كالتالي: نعمل الجدول tbl_Salary والذي سيشمل جميع الجداول الثمانية ، وبدون حقلي "المحسوب" ، ومع اضافة حقل اسم "المجموعة" : . والنتيجة : . وعلى اساس هذا الجدول ، نعمل استعلام qry_Salary ، ونضيف الحقلين "مج الاستقطاع" و "الصافي" مع معادلاتهم : . ومقارنة سجلات الجدول السابق مع الاستعلام الجديد : . والآن وبكل بساطة تعمل الاستعلام الذي يقوم بعملية جمع الصافي : . والنتيجة : . جعفر 1197.wameed.accdb.zip
  4. 5 points
    بارك الله فيك اخي الكريم على الرد ولكن قاعدة البيانات فرنسية فقط عربتها لك حتى تفهم علي وشكرا بالنسبة للملاحظة لقد عدلت العنوان وشكرا لك مع فائق الاحترام و التقدير تحياتي
  5. 5 points
    تحديد عدد السجلات المراد عرضها تباعا فى نموذج مستمر اعتذر جدا صادفت مشكلة بعد رفع المرفق وهو حدوث خلل عند مسح سجلات من منتصف الجدول لان فكرتى اعتمدت على حقل الترقيم التلقائي ولما حدث خلل بالترتيب حدث خلل بعرض النماذج ولازلت افكر بكيفة الحل تم حل المشكلة بفضل الله وتم تحديث المرفق عدد السجلات للنموذج المستمر v.2.mdb
  6. 5 points
    نعم ممكن ومن اسهل الطرقلتنفيذ ذلك If Me![c_8].Caption = "نساء" Then Me.Type = "نساء" Me.c_8.Caption = "رجال" ElseIf Me![c_8].Caption = "رجال" Then Me.Type = "رجال" Me.c_8.Caption = "اطفال" ElseIf Me![c_8].Caption = "اطفال" Then Me.Type = "اطفال" Me.c_8.Caption = "نساء" End If وتفسيرة كما يلي اذا كانت تسمية زر الامر نساء اجعل قيمة النوع نساء غير تسمية الامر الى رجال اذا كانت تسمية الامر رجال اجعل النوع رجال غير تسمية الامر الى اطقال اذا كانت تسمية الامر اطفال اجعل النوع اطفال غير التسمية لزر الامر الى نساء وذلك للاستمرار في دورة تنفيذ الكود اغلق الشرط الملف مرفق Database1011.accdb
  7. 4 points
    السلام عليكم أريد أن أصنع برنامج خاص بالسيارات و تتمحور كاالآتي : طراز السيارة و نوعها التسجيل السيارة على سبيل المثال اين ذهبت و متى دخلت تعيين السيارة أي السارة الموجهة الى اين هي ذاهبة معلومات السائق منها الاسم واللقب و تاريخ ومكان الميلاد الوظفة التوفيت رقم السجل الخ ...... حصة الوقود لكل مركبة اصلاح السيارة باسم المورد قطع الغيار المتغيرة لكل مركبة باسم المورد الصورة المصغرة عمل تشحيم السيارة حبذا يكون ايضا فيها خاصية اضافة الصور للمورد و ايضا المركبات و استخراج المطبوعات شكرا لكم تحياتي الخاصة لك
  8. 4 points
    بعد اذن استاذى القدير الاستاذ @kha9009lid🌹 وهذه على طريقة المعقدين امثالي😀 Database1012.accdb
  9. 4 points
    وعليكم السلام 🙂 سؤالك هو: تظهر لك رسالة خطأ التالية: . ويكون المؤشر باللون الازرق في الكود على: . والحل هو: ان تعمل استبدال ctrl+h لجميع الكود : او تغيير اسم قاعدة بياناتك هنا ، الى اسم آخر غير عن Database او db او الاسماء المحجوزة للأكسس : . جعفر
  10. 4 points
    مرحبا استاذ @ازهر عبد العزيز اولا اعتذر عن التعديل على مرفقك لعدم توفر اكسس لدي لكون عملي حاليا في بيئة عمل مختلفة وفي هذا الرد سوف اضع تلميح لكيفية التحكم بانواع الحقول من خلال الكود واعتذر مقدما اذا لم تجد فيه الجواب المطلوب لتغيير الحقل الى نوع رقم Dim x As Variant x = "ALTER TABLE [tbl1] ALTER COLUMN [tx8] LONG" DoCmd.RunSQL x ويمكن كتابتة بالشكل التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Integer" او DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] LONG" حسب نوع الحقل الرقمي تغيير الحقل الى نوع مزدوج يكون على النحو التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Double" الى نوع نص DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] String" واذا اردنا ان نحدد طول الحقل النص يمكن كتابتة DoCmd.RunSQL ("ALTER TABLE [tbl1] ALTER COLUMN [tx8] TEXT(30);") اما حقل التاريخ فيكون DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] date" النوع العملة يكون على النحو التالي DoCmd.RunSQL "ALTER TABLE [tbl1] ALTER COLUMN [tx8] Currency" لتحويل تنسيق الحقل الى علمي Set db = CurrentDb db.TableDefs("tbl1").Fields("tx8").Properties.Append db.CreateProperty("Format", dbText, "scientific") بعد تعديل التنسيق بالكود السابق تحتاج الى التعديل اليدوي في حالة الرغبة في التغيير مرة اخرى في جميع الاحوال لا انصح بالعبث في الحقول والمفروض ان التخطيط الجيد قبل واثناء انشاء قواعد البيانات يغني عن الحاجة للتعديلات اضافة الى ان تغيير نوع الحقل قد يؤدي الى فقدان البيانات لهذا الحقل وخصوصا اذا كان الحقل مرتبط بجداول اخرى قد يعطل عمل القاعدة
  11. 4 points
    جرب هذا الماكرو Option Explicit Sub ALL_in_one_cells() Dim ro, st$, i% ro = Cells(Rows.Count, 1).End(3).Row For i = 1 To ro If Cells(i, 1) <> vbNullString Then st = st & Cells(i, 1) & "," End If Next st = Mid(st, 1, Len(st) - 1) & "." Cells(3, 4) = st Cells(3, 4).Columns.AutoFit End Sub الملف مرفق One_for_All.xlsm
  12. 4 points
    أحسنت استاذ محمد بارك الله فيك وزادك الله من فضله تم التجربة ويعمل بكل كفاءة
  13. 4 points
    فيك الخير والبركة استاذنا الفاضل جعفر ادامك الله ذخرا لإخوانك
  14. 4 points
  15. 3 points
  16. 3 points
    لم استطع تحميل الملف المرفق ضع الكود التالي في module الحفظ الافتراضي سيكون في Desktop بعد اختيار اسم للملف المصدر Public Sub Save_Range_As_PDF_On_Desktop() Dim fileName As String, saveAsFileName As Variant Dim PDFrange As Range With Sheets("sheet13") Set PDFrange = .Range("a1:j286") End With saveAsFileName = Application.GetSaveAsFilename(InitialFileName:=Get_SpecialFolderPath("Desktop") & fileName, _ FileFilter:="PDF file (*.pdf), *.pdf", _ Title:="Save PDF file") If saveAsFileName <> False Then PDFrange.ExportAsFixedFormat Type:=xlTypePDF, fileName:=saveAsFileName, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If End Sub Private Function Get_SpecialFolderPath(SpecialFolderName As Variant) As String Get_SpecialFolderPath = CreateObject("WScript.Shell").SpecialFolders(SpecialFolderName) & "\" End Function
  17. 3 points
    السلام عليكم 🙂 1. رجاء انزل البرنامج المرفق ، ثم انسخ الكائنين منه الى برنامجك الرئيسي ، واحذف البرنامج المرفق ، ثم العمل على نسخة من برنامجك الاصلي ، 2. تأكد ان جميع النماذج مغلقه ، ثم افتح النموذج zfrm_Testing ، وانقر على الزر . 3. هذا سيعمل مجلدات في مجلد برنامجك ، وفي كل مجلد المرفقات التي به (حسب ID سجل برنامجك) ، وسيقوم بتصدير جميع مرفقاتك الى المجلدات : . 4. لما ينتهي البرنامج من تصدير الملفات ، سيعطيك رسالة Done ، 5. افتح النموذج Masttr Form2 ، وسترى المرفقات موجودة على يمين الشاشة (انظر للصورة في الاسفل) ، 6. المرفقات في الاعلى تابعة للنموذج الرئيسي ، والمرفقات في الاسفل تابعة للنموذج الفرعي (رجاء التاكد ان المرفقات صحيحة ، وهي نفسها الموجودة في برنامجك) : . انا لم اقم بعمل كود لحذف اي شيء من برنامجك ، اذا اردت ان تضيف مرفق جديد ، فتستطيع ان تمسكه من متصفح الملفات ، وتفلته Drag and Drop سواء في المجلد العلوي او السفلي ، البرنامج تلقائيا يضيف المجلدات. بعد ان تتأكد ان البرنامج يعمل بطريقة صحيحة ، تستطيع يدويا ان تحذف حقول المرفقات من جدوليك ، ثم استعمل ضغط واصلاح 🙂 هذا هو الكود الموجود في النموذج zfrm_Testing ، والذي يصدر المرفقات الى مجلدات و ملفات خارجية : Private Sub cmd_Export_Attachments_Click() On Error GoTo err_cmd_Export_Attachments_Click Dim rst_tbl As DAO.Recordset Dim rst_Att As DAO.Recordset Dim myDir As String Dim File_Name As String 'table name : [Mastr Table] 'Attachment filed name : [مرفقات] Set rst_tbl = CurrentDb.OpenRecordset("Select * From [Mastr Table]") While Not rst_tbl.EOF ' Loop through the table 'check if the Dir exists, if not, make it myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments Call Make_Dir(myDir) myDir = myDir & "\Mastr_Table" 'Mastr_Table Call Make_Dir(myDir) ' myDir = myDir & "\" & rst_tbl![CUSTOMER COD] 'Customer_Code ' Call Make_Dir(myDir) myDir = myDir & "\" & rst_tbl!ID 'ID Call Make_Dir(myDir) Set rst_Att = rst_tbl.Fields("[مرفقات]").Value While Not rst_Att.EOF ' Loop through the attachments. ' File_Name = myDir & "\" & rst_tbl!ID & "_" & rst_Att.Fields("Filename") 'ID and Attachment names ' rst_Att.Fields("FileData").SaveToFile File_Name ' Save current attachment rst_Att.Fields("FileData").SaveToFile myDir rst_Att.MoveNext Wend 'rst_Att rst_tbl.MoveNext Wend 'rst_tbl '' ' '[Payment Table] '[مرفقات] Set rst_tbl = CurrentDb.OpenRecordset("Select * From [Payment Table]") While Not rst_tbl.EOF ' Loop through the table 'check if the Dir exists, if not, make it myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments Call Make_Dir(myDir) myDir = myDir & "\Payment_Table" 'Mastr_Table Call Make_Dir(myDir) ' myDir = myDir & "\" & rst_tbl![CUSTOMER COD] 'Customer_Code ' Call Make_Dir(myDir) myDir = myDir & "\" & rst_tbl!ID 'ID Call Make_Dir(myDir) Set rst_Att = rst_tbl.Fields("[مرفقات]").Value While Not rst_Att.EOF ' Loop through the attachments. ' File_Name = myDir & "\" & rst_tbl!ID & "_" & rst_Att.Fields("Filename") 'ID and Attachment names ' rst_Att.Fields("FileData").SaveToFile File_Name ' Save current attachment rst_Att.Fields("FileData").SaveToFile myDir rst_Att.MoveNext Wend 'rst_Att rst_tbl.MoveNext Wend 'rst_tbl rst_tbl.Close: Set rst_tbl = Nothing rst_Att.Close: Set rst_Att = Nothing Exit_cmd_Export_Attachments_Click: MsgBox "Done" Exit Sub err_cmd_Export_Attachments_Click: If Err.Number = 3420 Then 'ignore rst not there Resume Next ElseIf Err.Number = 3839 Then 'file exists Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub Public Function Make_Dir(Dir_Name As String) As Boolean 'Make_Dir = True ' a new Directory was made 'Make_Dir = False ' the Directory Exists 'check if the Dir exists, if not, make it If Dir(Dir_Name, vbDirectory) = "" Then MkDir Dir_Name Make_Dir = True ' a new Directory was made End If End Function . وهذا كود لحدث الحالي والذي يُظهر المرفقات في كائن webbrowser في النموذج Masttr Form2 : Dim myDir As String 'Mastr_Table, Dir exists, if not, make it myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments Call Form_zfrm_Testing.Make_Dir(myDir) myDir = myDir & "\Mastr_Table" 'Mastr_Table Call Form_zfrm_Testing.Make_Dir(myDir) myDir = myDir & "\" & Me!ID 'ID Call Form_zfrm_Testing.Make_Dir(myDir) 'Payment_Table, Dir exists, if not, make it myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments Call Form_zfrm_Testing.Make_Dir(myDir) myDir = myDir & "\Payment_Table" 'Payment_Table Call Form_zfrm_Testing.Make_Dir(myDir) myDir = myDir & "\" & Me!ID 'ID Call Form_zfrm_Testing.Make_Dir(myDir) 'specify that the browser is an object in the Form Set web = Me.objIE.Object Set web_2 = Me.objIE_2.Object 'Master, Open/Navigate the page myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments myDir = myDir & "\Mastr_Table" 'Mastr_Table myDir = myDir & "\" & Me!ID web.Navigate myDir 'Payment, Open/Navigate the page myDir = Application.CurrentProject.Path & "\Attachments" 'Attachments myDir = myDir & "\Payment_Table" 'Mastr_Table myDir = myDir & "\" & Me!ID web_2.Navigate myDir جعفر 1195.zip
  18. 3 points
    بعد اذن استاذنا سليم , ولإثراء الموضوع يمكنك وضع هذه الأكواد فى حدث الصفحة Dim mRg As Range Dim mStr As String Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Range("A2:D1000"), Target) Is Nothing Then Set mRg = Target.Item(1) mStr = mRg.Value End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim xRg As Range On Error Resume Next Set xRg = Intersect(Range("A2:D1000"), Target) If xRg Is Nothing Then Exit Sub Target.Worksheet.Unprotect Password:="123" If xRg.Value <> mStr Then xRg.Locked = True Target.Worksheet.Protect Password:="123" End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Range("A2:D1000"), Target) Is Nothing Then Set mRg = Target.Item(1) mStr = mRg.Value End If End Sub
  19. 3 points
    هذا الكود ربما يساعدك Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a, b, c a = Not Intersect(Target, Union(Range("A2:A1000"), _ Range("D2:D1000"))) Is Nothing b = Target.Cells(1) <> vbNullString c = Target.Count = 1 Application.EnableEvents = False If a * b * c <> 0 Then Target.Offset(, 1).Select End If Application.EnableEvents = True End Sub
  20. 3 points
    أولاً في هذه الحالة لست بحاحة الى arr_num ثانياً الكود الصحيح Option Explicit Sub give_data() If ActiveSheet.Name <> "data" Then Exit Sub Dim Laste_Row%, k%, m%, i% Dim arr Dim rg As Object Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row Sheets("data2").Range("A3").Resize(3000, 3).ClearContents Set rg = CreateObject("system.collections.arraylist") i = 3 With rg Do Until i > Laste_Row If Not .Contains(UCase(Range("h" & i).Value)) Then .Add UCase(Range("h" & i).Value) i = i + 1 Loop arr = .toarray End With m = 3 For i = LBound(arr) To UBound(arr) For k = 3 To Laste_Row% If Sheets("data").Cells(k, "H") = arr(i) Then With Sheets("data2").Cells(m, 1) .Value = Sheets("data").Cells(k, "A") .Offset(, 1) = Sheets("data").Cells(k, "Y") .Offset(, 2) = Sheets("data").Cells(k, "H") m = m + 1 End With End If Next Next Set rg = Nothing: Erase arr End Sub
  21. 3 points
    اذا بكره الله سبحانه وتعالى اعطانا عمر ، فأشوف الموضوع ان شاء الله 🙂 جعفر
  22. 3 points
    ضع MYFOLDER في C الملف يعمل بكفاءة عالية افتح الملف MASTER و قم بجلب الملفات. الكود يعمل بكفاءة عالية. ربما المشكل عندك في الجهاز MyFolder.rar
  23. 3 points
    وعليكم السلام اخى الكريم ,كان عليك استخدام خاصية البحث فى المنتدى فقد تكرر هذا الموضوع مئات المرات ومنه كما ترى: طباعة شيتات مرتب دفعة واحدة تعديل كود : طباعة أوراق محددة .. طباعة كل الشهادات كود طباعة لكل تسلسل الاسماء من نتائج معادلة vlookp من قائمة بمجموعة اسماء
  24. 3 points
    بعد اذن الاستاذ واتراء للموضوع يمكنك استخدام الكود التالي في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim rng Dim lr lr = Cells(Rows.Count, 1).End(3).Row Set rng = Range("a3:a" & lr) If Not Intersect(Target, rng) Is Nothing Then Range("j3:j" & lr).Formula = "=B3&"" ""&C3&"" ""&D3&"" ""&E3" Value = Value End If End Sub
  25. 3 points
    وعليكم السلام-جرب هذا How to Copy or Import VBA Code to Another Workbook أو هذا Copy every worksheet from one excel file to another او يمكنك بطريقة بسيطة بأن تقوم بتحديد كل صفحات الملف بطريقة يدوية ثم بعد ذلك تقوم بالضغط كليك يمين بالماوس ثم اختيار move or Copy ثم بعد ذلك اختيار ملف الإكسيل الذى تريد نقل الصفحات اليه وتحديد كل الصفحات التى تريد نقلها ... فسيتم النقل ايضا بالمعادلات وبنفس تنسيقات الملف القديم اما بالنسبة لنقل الأكواد فقط عليك بفتح الملف القديم والملف الجديد والدخول الى محرر الأكواد بالضغط على Alt F11 ثم الضغط الى الكود الذى تريد نقله وسحبه الى المكان الجديد بالملف الجديد
  26. 3 points
  27. 2 points
    السلام عليكم 🙂 حيا الله اخوي رمهان 🙂 اخوي اباجودي ، هنا عملنا شيء مشابه لما تريد ، التصفح كل 10 سجلات : جعفر
  28. 2 points
    اتفضل 🌹 المشكله بسبب الكود الموضوع على حقل القراءة الحالية فى حدث عند الإدخال فى النموذج الفرعى جعل السحل الحالى فى وضع التعديل لذلك كان يحدث تعارض تم العمل على الابتعاد عن التداخل مع الحفاظ على الية العمل تع تصميمك اسف ع التاخير شغال من موبايل والموضوع صعب عليه تجربة-2.zip
  29. 2 points
    مشاركه مع اخى واستاذى محمد @ابا جودى جرب الان ووافنا بالنتيجه تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق تجربة_2.rar
  30. 2 points
    اخى @husseinharby هذا لانك لم تقم بجميع التعديلات المطلوبه فالكود يعتمد على التاج او العلامه افتح الجدول revision وانظر اليه ستجد به سجلات الان قم بالتعديل على الحقول اللتى تريدها باضافه القيمه Audit كما بالصوره تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق De55sktop.rar
  31. 2 points
    جرب هذا الكود Sub test() Dim My_RG As Range Set My_RG = Application.InputBox("Select Your Range Please", Type:=8) Range(My_RG.Address).Select End Sub Selection_by_Choise.xlsm
  32. 2 points
    اخينا @wael gaper الكود سليم ويتم عرض اخر سجل في مجموعة السجلات ولكن يبقى ماهو اخر سجل ؟ فالجدول به البيانات غير مرتبه لذلك كيف نضمن ان اخر سجل نريده هو اخر سجل بمجموعة السجلات . نقوم بعمل ترتيب صريح اما من خلال الجدول وتكون مرئيه علامة الفرز بالجدول عند فتحه او تقوم بفتح السجلات بجملة اس كيو ال متضمنه امر الفرز وحسب ماتريد غير اسم الجدول وعمود الفرز وعذرا اكتب من الموبايل بالتوفيق
  33. 2 points
    السلام عليكم ورحمة الله وبركاته بعد اذن استاذى الغالي الاستاذ @محمد ابوعبد الله 🌹 هذه الفكرة خطرت على بالي input mask with code.mdb
  34. 2 points
    طيب ممكن نقول ان الموضوع ده انفراد وحصري لمنتدياتنا منتديات اوفيسنا التصميم والأفكار والاكواد من بنات افكارى ام سبقنا اليه غيرنا
  35. 2 points
    اخى واستاذى العزيز محمد @ابا جودى للتغلب على مشكله عدم ظهور البيانات بعد الحذف قمت بوضع الكود التالى كمصدر للسجلات عند الفتح Private Sub Form_Open(Cancel As Integer) strSql = "SELECT TOP 10 tblData.ID, tblData.[NO], tblData.Locatin, tblData.SecName, tblData.DepName, tblData.RegDate FROM tblData;" Me.RecordSource = strSql Call RecordCount Call RecordCount End Sub
  36. 2 points
    نور الموقع بمشاركة ابا جودي استاذنا الغالي كما تعلم يا ابا جودي رواد الموقع فيهم المحترف ومتوسط المستوى والمبتدي وفي ردودي احاول دائما ان ابسط الردود ليستوعبها المبتدي حتى لو كان الكود اطول لان الاختصار واستخدام المتغيرات قد لا يستوعبه غير المحترفين لذا في كثير من ردودي اشرح ماقمت به ليكون الحل اكثر وضوحا للمتلقي وتقبل اطيب تحياتي نورت الموقع دكتور حلبي
  37. 2 points
  38. 2 points
    بعد اذن الاخ سليم تجربة لحل باستخدام دالة اخرى Test2.xlsx
  39. 2 points
    وعليكم السلام 🙂 1. انت محتاج الى هذا الكود لنسخ المرفقات من قاعدة البيانات الى مجلد في الكمبيوتر : ' 'from 'https://docs.microsoft.com/en-us/office/vba/access/Concepts/Data-Access-Objects/work-with-attachments-in-dao ' ' Instantiate the parent recordset. Set rsEmployees = db.OpenRecordset("Employees") 'Code to move to desired employee ' Instantiate the child recordset. Set rsPictures = rsEmployees.Fields("Pictures").Value ' Loop through the attachments. While Not rsPictures.EOF ' Save current attachment to disk in the "My Documents" folder. rsPictures.Fields("FileData").SaveToFile _ "C:\Documents and Settings\Username\My Documents" rsPictures.MoveNext Wend 2. حذف حقول الرفقات من برنامجك ، 3. اذا عندك اكثر من مرفق لنفس السجل ، فالافضل ان تعرض اسماء المرفقات في النموذج ، والمستخدم ينقر على الصورة اللي يريده ، ويشوفها في النموذج : . جعفر
  40. 2 points
    وهذا الكود يقوم بنفس العمل لكن مع عدد متغير من الصفوف يكفي ان تضع في الخلية I1 عدد الصفوف التي تريدا وتضغط على الزر Run مع تحديد نطاق الطباعة حسب الداتا التي حصلنا عليها Option Explicit Sub give_data_by_Y() If ActiveSheet.Name <> "data" Then Exit Sub Dim D As Worksheet, D2 As Worksheet Dim i%, x%, n%, Laste_Row%, Ro%, col%, m%, k%, last_col% Dim arr(), Tile() Dim y Set D = Sheets("data"): Set D2 = Sheets("data2") y = D.Range("i1") Laste_Row = D.Cells(Rows.Count, 1).End(3).Row D2.Cells.Clear x = (Laste_Row \ y) + 1 k = 1 ReDim arr(1 To x) For m = 1 To x arr(m) = y * (k - 1) + 3 k = k + 1 Next Ro = 3: col = 1 '++++++++++++++++++++++++++ Get The Result For k = 1 To UBound(arr) With D2.Cells(Ro, col).Resize(y) .Value = _ D.Range("A" & arr(k)).Resize(y).Value .Offset(, 1).Value = _ D.Range("B" & arr(k)).Resize(y).Value .Offset(, 2).Value = _ D.Range("G" & arr(k)).Resize(, y).Value End With D2.Cells(1, col + 3).ColumnWidth = 0.75 D2.Cells(4, col + 3).Formula = "=""""" col = col + 4 Next '++++++++++++++++++++++++++End Of The Result '__________________________Type The Titles last_col = D2.Cells(3, Columns.Count).End(1).Column Tile = Array("رقم ", "الاسم و اللقب ", "القسم") For m = 1 To last_col Step 4 D2.Cells(2, m + 3).Resize(y + 1). _ Interior.ColorIndex = 40 D2.Cells(2, m).Resize(, 3) = Tile Next '__________________________ End Of Typing The Titles '++++++++++++++++++++++++++ Format The Result With D2.Cells(2, 1).Resize(y + 1, last_col) .Borders.LineStyle = 1: .HorizontalAlignment = 1 .VerticalAlignment = 2: .Font.Size = 14 .Font.Bold = True: .InsertIndent 1 .Columns.AutoFit End With With D2.Cells(2, 1).Resize(, last_col) .HorizontalAlignment = 3 .Interior.ColorIndex = 6 End With n = Application.CountA(D2.Cells(2, last_col - 2).Resize(y)) If n < y Then D2.Cells(n + 2, last_col - 3).Resize(y - n + 1, 5).Clear End If '++++++++++++++++++++++++++ End Of The Format Of Result D2.PageSetup.PrintArea = D2.Range("A2").Resize(y + 1, last_col).Address Set D = Nothing: Set D2 = Nothing Erase arr: Erase Tile End Sub File Included New_std_salim_1.xlsm
  41. 2 points
    اضف هذا السطر الوحيد(بين علاملات الـــ +) في المكان المناسب لم استطع رفع الكود من جديد لضعف النت If m=7 then MsgBox "No Data to transfer": Exit Sub
  42. 2 points
    كذلك اعتذر منك ، اعطيتك امر اول حرف ، ونسيت الباقي !! [m_name] = Replace(Mid([m_name],1,1), "أ", "ا") & Mid([m_name],2) او [m_name] = Replace(left([m_name],1), "أ", "ا") & Mid([m_name],2) جعفر
  43. 2 points
    وعليكم السلام-لك ما طلبت تحويل الارقام الى عربي عند استدعاء البيانات1.xls
  44. 2 points
    أخي عبد الله السعيد . يمكن أنك تستعمل ملفات أخرى غير المرسلة من طرفك 1- يجب أن تكون الملفات هنا : C:\MyFolder و اذا كانت ملفاتك في مجلد آخر غيره في الكود : في هذا السطر fPath = "C:\MyFolder\" 2- تأكد من امتداد الملفات 3-اسم الورقة التي تجلب منها البيانات في الملفات المتعددة ربما ليست SHEET1 غيرها في الكود اذا كنت تستخدم اسم آخر في هذا السطر LR = Worksheets("SHEET1").Range("XEY" & Rows.Count).End(xlUp).Row Worksheets("SHEET1").Range("XEY2:XFD" & LR).Copy 4- ربما ورقة العمل في الملف الرئيسي ليست "MASTER"في ملفك الرئيسي . غيرها في هذا السطر Set wsMaster = ThisWorkbook.Sheets("Master") بالتوفيق
  45. 2 points
    تفضل أخي أكتب فقط تاريخ البدء و الساعة في الخلية C7 . و اكسل يقوم بالباقي. يمكنك سحب المعادلات الى الاسفل لمزيد من اسماء المداومين. جدول المداومة.xlsx
  46. 2 points
    لم أفهم المطلوب. لكن هذه محاولة لاستخراج تاريخ آخر قسط من العمود J الى العمود AM ثم حساب المدة منذ آخر قسط. عدد الشهور المستحقة حتى الان.xls
  47. 2 points
    بارك الله فيك وزادك الله من فضله ورحم الله والديك
  48. 2 points
    وفيك بركة أخي أ / محمد صالح و عيدك مبارك وكل عام و أنت بألف خير و تقبل الله منا ومنكم صالح الأعمال .... أخوك في الله : مناد سفيان .
  49. 2 points
    مشكور أخي أ / محمد صالح على ملاحظاتك حتى أتمكن من ترجمتها كليا و لك مني ألف تحية
  50. 2 points

    Version 1.0.0

    125 تنزيل

    السلام عليكم ورحمة الله وبركاته برنامج عملته في 2007 ، لإختيار الكلمات من بين حوالي 618 الف كلمة ، لأعمل قافية لأبيات الشعر الواجهة: 1. اكتب الحرف/الحروف التي تريد ان تكون عليها القافية (اي ان تنتهي الكلمة بهذا الحرف/الحروف) ، 2. اكتب الحرف/الحروف التي تبدأ الكلمة بهذا ، 8. كلمات البحث في #1 و #2 تظهر هنا ، 3. عند كتابة الحروف في #1 او #2 ، فالبحث يكون عن طريق هذا الزر ، (وتستطيع الكتابة في #1 او #2 ، و رقم 4) ، 4. اكتب الكلمة التي تريدها ، وستظهر لك الكلمات المرادفه لها ، 5. للبحث للرقم 4 ، 9. كلمات البحث في #4 تظهر هنا ، 6. لحذف جميع كلمات البحث ، بالاضافة الى انه يمكن النقر مرتين على #1 او #2 او #4 لحذف الكلمة/الحرف/الحروف من الحقل ، 7. نريد ان نختار من الكلمات الموجودة في #8 ، فننقر على #7 لحفظها مؤقتا في نموذج جديد . البحث في الكلمات التي تنتهي بالحروف ليل . وعند النقر على الزر A فتنتقل الكلمة الى النموذج هذا . البحث في الكلمات التي تبدأ بالحروف خل . البحث عن الكلمات المرادفة لكلمة شجاع . البحث عن الكلمات المرادفة لكلمة شجاع ، والتي تنتهي بالحرف ت . وعند الانتهاء من اختيار الكلمات ، وعند النقر على زر Copy to Notepad ، سيتم حفظها في ملف باسم Poem.txt في نفس مجلد البرنامج ، . المربع الاحمر: الكلمات في النموذج اعلاه يتم البحث عنها في الحقل #2 ، وإظهار نتائج الحقل #1 ، ومعاني الكلمات موجودة في الحقل #3 ، المربع الازرق: الكلمة في #4 هي عكس الكلمة في الحقل #2 ، والحقل #5 فيه معنى هذه الكلمة . بدأت بأخذ كلمات القرآن الكريم ، ثم بكسر الحماية من ملف الكلمات/القاموس في برنامج Ms Word واخذ كلماته ، فأصبح عندي حوالي 48 الف كلمة ، ولكن لم تكن الكلمات كاملة ، فأنزلت من الانترنت جميع القواميس العربية ومعانيها ، وادخلتها جميعا في البرنامج ، فوصل عدد الكلمات الى حوالي 618 الف كلمة ، عملت عدة كودات (والتي تركتها في البرنامج للذي يريد ان يستفيد منها) لتصفية الكلمات و اكواد اخرى للتعامل مع MS Word ، حيث ارسل الكلمة للوورد ، ثم آخذ المعاني منها ، وكذلك لمعرفة مقلوب الكلمة ، اذا كان لها معنى ، وإلا فلم اكتب الكلمة. ارجوا ان تستفيدوا من البرنامج ، مثل ما انا استفدت منه يوما ما جعفر


×
×
  • اضف...