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

تطبيق 1.xlsx السلام عليكم ورحمة الله لم أزد جديدا على ما قام به الإخوة الأكارم في ردودهم...

تفضل تطبيق 1.xlsm

فنان.xlsm

أخي الكريم لماذا كل هذا التردد والحيرة؟؟؟؟!!!!!! عرضت قبل ذلك مشكلتك هـــــــــتا وحذرتك من اختلاف طريقة التعامل مع الأرقام فبعض الأرقام تضرب في 1000 وبعض الأرقام توضع كما هي وباستجوابك توصلنا إلى أنه إذا كانت الأرقام موجبة تضرب في 1000 وإذا كانت الأرقام سالبة توضع كما هي واليوم تضع اختلافا جديدا حيث تريد أن بعض الأرقام الموجبة تضرب في 1000 وبعضها لا تضرب!!!!!! فعلي أي أساس؟؟؟ وللمرة المليون يجب توحيد طريقة التعامل مع المدخلات فإذا كنت تضرب في 1000 فيجب كتابة ال 1000 بصورة 1 وفي هذه الحالة يكوزن المجموع 1+2 = 3 في 1000 = 3000 وكذلك في حالة الأرقام السالبة تريد إنقاص 500 تكتب - 0.5 عند الضرب في 1000 = -500 بهذه الطريقة ستقلل طول المعادلة وتقلل نسبة الخطأ بالتوفيق

وعليكم السلام ورحمة الله وبركاته إذا كان اصدار الأكسل لديك لا يدعم الصفيف فلابد من ضغط كنترول +شفت + انتر ctrl+shift +enter بعد تحرير المعادلة مصنف (2).xlsx

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

ويمكن اختصار الكود ليصبح كالتالي: Me.NOTE.Enabled = Me.الرمز = "A" Me.TIME_WORK.Enabled = Me.الرمز = "A" أو كالتالي: Me.NOTE.Locked = Me.الرمز <> "A" Me.TIME_WORK.Locked = Me.الرمز <> "A"

تفضل .. تضع هذا الكود بعد تحديث حقل الرمز و في الحالي If Me.الرمز = "A" Then Me.NOTE.Enabled = True Me.TIME_WORK.Enabled = True Else Me.NOTE.Enabled = False Me.TIME_WORK.Enabled = False End If BASEF1.accdb

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

يصبح الكود هكذا Dim ons As String Dim typefld As String ons = [id_Flightpermits_lab] SourceFile = filepath_att typefld = Right(SourceFile, Len(SourceFile) - InStrRev(SourceFile, ".")) DestinationFile = CurrentProject.Path & "\image\" & ons & "." & typefld FileCopy SourceFile, DestinationFile [link_file] = DestinationFile MsgBox "تم النسخ بنجاح" قاعدة2.rar

تفضل Dim SourceFile, DestinationFile Dim ons As String ons = [id_Flightpermits_lab] SourceFile = filepath_att DestinationFile = CurrentProject.Path & "\image\" & ons & ".jpg" FileCopy SourceFile, DestinationFile [link_file] = DestinationFile Downloads.rar

كبداية إن شاء الله ووضع القاعدة الرئيسية لموضوع التوزيع ،، 🙂 قمت بطلب عمل التوزيع حسب الشروط المذكورة من موقع الذكاء الاصطناعي .. فكان هذا جوابه : --------------------------------------------------------------------------------------------------------------------- التحدي الذي واجهته في طلبك هو معقد نوعًا ما ويتطلب تحليلًا دقيقًا وتنفيذًا متقنًا. للأسف، لا يمكنني تقديم الكود الكامل والنهائي هنا بسبب تعقيد المطلوب. ومع ذلك، يمكنني تقديم نمط عام لكيفية تنفيذ هذا التحدي باستخدام VBA في Microsoft Access. ستحتاج إلى تخصيص هذا النمط وفقًا لاحتياجاتك وبنية قاعدة البيانات الخاصة بك. Sub DistributeLessons() Dim startDate As Date Dim endDate As Date Dim currentWeek As Integer Dim weekStartDate As Date Dim weekEndDate As Date Dim studentRS As Recordset Dim teacherRS As Recordset Dim lessonRS As Recordset Dim vacationRS As Recordset ' Set start date and end date startDate = #8/1/2023# endDate = #8/31/2023# ' Set up recordsets for students, teachers, lessons, and vacations Set studentRS = CurrentDb.OpenRecordset("Tbl_Students") Set teacherRS = CurrentDb.OpenRecordset("Tbl_Teachers") Set lessonRS = CurrentDb.OpenRecordset("Tbl_Lessons") Set vacationRS = CurrentDb.OpenRecordset("Tbl_Vacations") ' Loop through the weeks in the month currentWeek = 1 weekStartDate = startDate Do While weekStartDate <= endDate weekEndDate = DateAdd("d", 6, weekStartDate) ' Assuming Sunday is the last day of the week ' Loop through each student studentRS.MoveFirst Do While Not studentRS.EOF ' Check if the student has lessons left for the week Dim lessonsLeft As Integer lessonsLeft = 2 ' Loop through each teacher teacherRS.MoveFirst Do While Not teacherRS.EOF ' Check if the teacher is on vacation for any day in the week Dim isOnVacation As Boolean isOnVacation = False vacationRS.MoveFirst Do While Not vacationRS.EOF If vacationRS!TeacherID = teacherRS!TeachersID And _ vacationRS!StartDateVacation <= weekEndDate And _ vacationRS!EndDateVacation >= weekStartDate Then isOnVacation = True Exit Do End If vacationRS.MoveNext Loop ' If the teacher is not on vacation, assign lessons If Not isOnVacation Then Dim lessonsAssigned As Integer lessonsAssigned = 0 ' Assign lessons to the teacher for the week ' Here you'll need to implement the logic for distributing lessons ' while respecting the constraints (group matching, max 2 lessons per student per week, etc.) ' Update the lessonsAssigned and lessonsLeft counters lessonsLeft = lessonsLeft - lessonsAssigned If lessonsLeft <= 0 Then Exit Do End If teacherRS.MoveNext Loop studentRS.MoveNext Loop ' Move to the next week weekStartDate = DateAdd("d", 7, weekStartDate) currentWeek = currentWeek + 1 Loop ' Close recordsets studentRS.Close teacherRS.Close lessonRS.Close vacationRS.Close End Sub يرجى مراجعة وتخصيص الكود أعلاه وفقًا لهيكل قاعدة البيانات الخاصة بك ومتطلباتك الدقيقة. الجزء الأكثر تعقيدًا هو توزيع الدروس بناءً على الشروط المذكورة، وهذا يتطلب تطوير الخوارزمية الملائمة لذلك. إذا واجهتك أي مشكلة خلال عملية التنفيذ، فلا تتردد في طرح الأسئلة.

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

كان الله في عونك تفضل QRSystem1.rar

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

تفضل أخي العزيز .. ولزيادة الخير وضعت لك أكواد جميع الإجراءات الأساسية : الإجراءات الإعتيادية للسجلات ( حفظ - جديد - حذف - إضافة - تكرار - التالي - السابق - الأول - الأخير - .....) '===================================== حفظ السجل والذهاب لسجل جديد Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord DoCmd.GoToRecord , , acNewRec Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== حذف السجل Private Sub DeleteBtn_Click() On Error GoTo Err_DeleteBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdDeleteRecord Exit_DeleteBtn_Click: Exit Sub Err_DeleteBtn_Click: MsgBox Err.Description Resume Exit_DeleteBtn_Click End Sub '===================================== إضافة سجل جديد Private Sub AddNewBtn_Click() On Error GoTo Err_AddNewBtn_Click DoCmd.GoToRecord , , acNewRec Exit_AddNewBtn_Click: Exit Sub Err_AddNewBtn_Click: MsgBox Err.Description Resume Exit_AddNewBtn_Click End Sub '===================================== السجل التالي Private Sub NextBtn_Click() On Error GoTo Err_NextBtn_Click DoCmd.GoToRecord , , acNext Exit_NextBtn_Click: Exit Sub Err_NextBtn_Click: MsgBox Err.Description Resume Exit_NextBtn_Click End Sub '===================================== السجل السابق Private Sub PreviousBtn_Click() On Error GoTo Err_PreviousBtn_Click DoCmd.GoToRecord , , acPrevious Exit_PreviousBtn_Click: Exit Sub Err_PreviousBtn_Click: MsgBox Err.Description Resume Exit_PreviousBtn_Click End Sub '===================================== السجل الأول Private Sub FirstBtn_Click() On Error GoTo Err_FirstBtn_Click DoCmd.GoToRecord , , acFirst Exit_FirstBtn_Click: Exit Sub Err_FirstBtn_Click: MsgBox Err.Description Resume Exit_FirstBtn_Click End Sub '===================================== السجل الأخير Private Sub LastBtn_Click() On Error GoTo Err_LastBtn_Click DoCmd.GoToRecord , , acLast Exit_LastBtn_Click: Exit Sub Err_LastBtn_Click: MsgBox Err.Description Resume Exit_LastBtn_Click End Sub '===================================== البحث عن سجل Private Sub FinedRecBtn_Click() On Error GoTo Err_FinedRecBtn_Click Screen.PreviousControl.SetFocus DoCmd.RunCommand acCmdFind Exit_FinedRecBtn_Click: Exit Sub Err_FinedRecBtn_Click: MsgBox Err.Description Resume Exit_FinedRecBtn_Click End Sub '===================================== تكرار السجل Private Sub DublicateRecBtn_Click() On Error GoTo Err_DublicateRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Exit_DublicateRecBtn_Click: Exit Sub Err_DublicateRecBtn_Click: MsgBox Err.Description Resume Exit_DublicateRecBtn_Click End Sub '===================================== حفظ السجل Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== طباعة السجل الحالي Private Sub PrintRecBtn_Click() On Error GoTo Err_PrintRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.PrintOut acSelection Exit_PrintRecBtn_Click: Exit Sub Err_PrintRecBtn_Click: MsgBox Err.Description Resume Exit_PrintRecBtn_Click End Sub '===================================== التراجع عن التسجيل Private Sub UndoRecBtn_Click() On Error GoTo Err_UndoRecBtn_Click DoCmd.RunCommand acCmdUndo Exit_UndoRecBtn_Click: Exit Sub Err_UndoRecBtn_Click: MsgBox Err.Description Resume Exit_UndoRecBtn_Click End Sub '===================================== فتح التقرير وطباعة السجل المحدد بدلالة الرقم التسلسلي Private Sub Print_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport, , "ID =" & Me.ID DoCmd.RunCommand acCmdPrintPreview DoCmd.RunCommand acCmdPrint Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: If Err.Number = 2501 Then Resume Exit_OpenReportBtn_Click 'print cancelled MsgBox Err.Number & vbCr & Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== طباعة تقرير Private Sub PrintReportBtn_Click() On Error GoTo Err_PrintReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acNormal Exit_PrintReportBtn_Click: Exit Sub Err_PrintReportBtn_Click: MsgBox Err.Description Resume Exit_PrintReportBtn_Click End Sub '===================================== معاينة تقرير Private Sub VeiwReportBtn_Click() On Error GoTo Err_VeiwReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acPreview Exit_VeiwReportBtn_Click: Exit Sub Err_VeiwReportBtn_Click: MsgBox Err.Description Resume Exit_VeiwReportBtn_Click End Sub '===================================== فتح تقرير Private Sub OpenReportBtn_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: MsgBox Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== حفظ تقرير بصيغة Private Sub SendReportToBtn_Click() On Error GoTo Err_SendReportToBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OutputTo acReport, stDocName Exit_SendReportToBtn_Click: Exit Sub Err_SendReportToBtn_Click: MsgBox Err.Description Resume Exit_SendReportToBtn_Click End Sub

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والاذكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود التنقل الى اي صفحة في ملف اكسيل طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' ' هذا الكود للعالم العلامة عبد الله باقسير Sub GO_TO() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If Activewindow.ScrollColumn = 1 Activewindow.ScrollRow = 1 On Error GoTo 0 End Sub في هذا الكود البسيط والمفيد عند الضغط على الزر ستنسدل قائمة بأسماء كل الصفحات الموجوده بالملف اختر منها الورقة التي تبعاها ودمتم في حفظ الله التنقل بين الصفحات.rar

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة التنقل بين الصفحات تم ارفاق كود الحل من الفاضل _ أ/ رحمه الله الحسامي _ عادل حنفي _ أبوعبد الله و لا تنسونا من صالح الدعاء تحياتى تنقل بين الصفحات (hossami).rar ورقة عمل Microsoft Excel adel1).rar new-ABO ABDALLAH.rar

السلام عليكم ورحمة الله وبركاته =============== Thermometer Chart ================= من خلال هذا الرسم البيانى يمكنك عرض المحقق من التارجيت او الهدف فى شكل ترموميتر . ملحوظه هذا الشكل يستخدم فى Dashborad وهو مشهورر وتم عرضها اليكم فى شكل خطوات مشروحة بالصور داخل ملف الاكسيل نفسه للاحتفاظ بها والتطبيق اتمنى ان تفيدكم وارجو منكم مشاركة الجميع (زكاة العلم نشره). thermometer.rar

السلام عليكم بارك الله فيكم جميعا وحل اخر بعد استنتاجه حلولكم الرااااااااااااائع تاريخ اخر فاتورة: IIf([الفواتير]>0;[التاريخ];#01/01/1900#) تاريخ اخر فاتورة.rar جزاااااااااااكم الله خيرا

السلام عليكم أختي الحائرة حسب معلوماتي أظن أنه لا يمكن إنشاء زر أمر في تقرير وبالتالي فكرت لك بهذين الحلين : * الأول هو أن تقومي بالضغط على مفتاحي Ctrl+P فتظهر لك خيارات الطباعة * الثاني هو أن تقومي بإنشاء حدث في التقرير.مثلا كحدث عند فتح التقرير وتقومي بكتابة الأمر التالي DoCmd.RunCommand acCmdPrint حينها سيظهر لك شاشاة خيارات الطباعة أرجو أن أكون قد توفقت في حل مشكلتك :$