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

السلام عليكم أستاذ @gavan 🙂 الفكرة التي أعمل بها في نفس السياق هي إضافة حقل عبارة عن قائمة منسدلة في جدول Reg_Book_Tbl مثلا .. وأسمي الحقل Status .. وهذه القائمة المنسدلة بها جميع المراحل التي يمر لها الكتاب مثال : 0 - تسجيل جديد 1 - قسم الوثائق 2 - قسم المعالجة 3 - معاد للتعديل 4 - جار المراجعة 5 -ناقصة . . 9 - مكتملة 10 - الأرشيف ثم أعمل كود بسيط يغير أو يقرأ الرقم الموجود في القائمة المنسدلة (على فكرة القائمة تكون من عمودين الرقم [مخفي] والحالة) لمعرفة حالة المعاملة وأين وصلت .. ولفرز السجلات الخاصة بكل قسم حسب الحالة .. نقوم بفلترة مصدر بيانات النموذج ليأخذ كل قسم ما يخصه . 🙂 يارب يكون الشرح واضح 😅✌

بعد بحثي عن هذا الملف من مشروع إدارة صالة أفراح في العاصمة عمان ، جرب هذا التعديل :- Afra7.accdb

تفضل استاذي فقط لغيت شرط الاسم من الكود .وطريقتي تتماشى مع كلام استاذي أبو خليل . WEEDING HALLS (113).rar

السلام عليكم مشاركه مع اخوتى واساتذتى اعجبتنى طريقه اخى الفاضل @Foksh جزاه الله خيرا وقمت بالتعديل عليها لان الخطأ الذى ظهر للاستاذ عبداللطيف بسبب ان التوقيت فى صباحا ومساء بالعربى وعند اخى فادى بالانجليزى وهذا ما احدث الخطأ فقمت بالتعديل عليها حيث تعلمت الطريقه من اخى فاضل هنا بالمنتدى جزاه الله عنا كل خير Private Sub Command7_Click() Dim rs As DAO.Recordset Dim sql As String sql = "SELECT 1 FROM Tbl_Party WHERE DATE_PARTY = #" & Me.DATE_PARTY & "# " & _ "AND ((" & CDbl(Me.TIME_PARTY_START) & " BETWEEN cdbl(TIME_PARTY_START) AND cdbl(TIME_PARTY_END)) " & _ "OR (" & CDbl(Me.TIME_PARTY_END) & " BETWEEN cdbl(TIME_PARTY_START) AND cdbl(TIME_PARTY_END)) " & _ "OR (cdbl(TIME_PARTY_START) BETWEEN " & CDbl(Me.TIME_PARTY_START) & " AND " & CDbl(Me.TIME_PARTY_END) & "))" Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot) If Not rs.EOF Then MsgBox "يوجد حجز مسبق لهذه الفترة!", vbExclamation, "تنبيه" Else CurrentDb.Execute "INSERT INTO Tbl_Party (DATE_PARTY, TIME_PARTY_START, TIME_PARTY_END) " & _ "VALUES (#" & Me.DATE_PARTY & "#, #" & Me.TIME_PARTY_START & "#, #" & Me.TIME_PARTY_END & "#)", dbFailOnError MsgBox "تم حفظ الحجز بنجاح!", vbInformation, "تأكيد" End If rs.Close: Set rs = Nothing End Sub تمنياتى لكم بالتوفيق WEEDING HALLS_1.accdb

جربت المثال شغال 100% كما تفضل الأخ موسى بالشرح

المعذرة من الجميع .. طبعا أنا طريقتي في النسخ الاحتياطي مختلفة تماما .. 😅🖐 وكل ما فعلته هو تأكدت أن كود صاحب الموضوع يعمل .. 😁👌 والعم فادي @Foksh ما يقصر معاكم 😄🌹

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

المشكلة في دالة BrowseForFolder على ما اعتقد ، وانا ايضاً لم يتم فتح مربع حوار اختيار مكان الحفظ . أما بالنسبة لي فأعتقد أنه من المفترض أن تكون النسخة الاحتياطية مؤمنة ومحفوظة في مكان واحد بشكل تلقائي داخل مجلد بجانب قاعدةالبيانات على سبيل المثال ، وأيضاً لي وجهة نظر مختلفة فيما يتعلق بموضوع النسخ الإحتياطي . فمثلاً ما حاجتي اذا كان النسخ الإحتياطي سيقوم بإنشاء نسخة كاملة من البرنامج ( الجداول والنماذج والاستعلامات .... إلخ ) تحت مسمى النسخة الإحتياطية !!!!!!! برأيي ان النسخة الاحتياطية للجداول فقط هي ما يهم المستخدم . لذا دائما أتوجه الى أخذنسخة احتياطية للجداول فقط . وهذا مرفق بسيط قديم من أحد مشاركاتي حسب طلب صاحب الموضوع السابق حينها ، ويتعامل مع القاعدة المنقسمة . Back.accdb

والجديد في البرنامج أنك تستطيع الآن البحث عن أي موظف بكل سهولك والانتقال إلى صفحته في الملف الخارج حتى تتأكد من بيانات والأن نأتي إلى برمجة ببانات التي سيتم طباعتها لكل موظف برنامج بطاقة عمل 2025 الخميس20-2-2025.xlsb

السلام عليكم ورحمة الله وبركاته الأستاذة الافاضل Foksh , kkhalifa1960 شكراً جزيلاً لكما على تواصلكم ومساعدتي في حل هذه المشكلة ، يبدو أن المشكلة في نسخة الـــoffice عندي هو الرابط حاليا يعمل لكن بعد ظهور رسالة الخطأ يعني عند الضغط على اللينك تظهر رسالة الخطأ ثم يفتح الرابط ، على العموم شكرا لكما مرة أخرى وما قصرتوا ؟

وعليكم السلام ورحمة الله وبركاته 🙂 هذا ما يحدث 🙂👇 (1) (2) (3) (4)

👍 Format(DateAdd("d", -1, Me.DATE_PARTY)

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

وعليكم السلام ورحمة الله وبركاته .. الأمر يسير أخي @عبد اللطيف سلوم ان شاء الله انشئ نموذج وفي زر التسجيل استخدم الكود التالي Private Sub Command7_Click() Dim rs As DAO.Recordset Dim sql As String sql = "SELECT 1 FROM Tbl_Party WHERE DATE_PARTY = #" & Me.DATE_PARTY & "# " & _ "AND ((#" & Me.TIME_PARTY_START & "# BETWEEN TIME_PARTY_START AND TIME_PARTY_END) " & _ "OR (#" & Me.TIME_PARTY_END & "# BETWEEN TIME_PARTY_START AND TIME_PARTY_END) " & _ "OR (TIME_PARTY_START BETWEEN #" & Me.TIME_PARTY_START & "# AND #" & Me.TIME_PARTY_END & "#))" Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot) If Not rs.EOF Then MsgBox "يوجد حجز مسبق لهذه الفترة!", vbExclamation, "تنبيه" Else CurrentDb.Execute "INSERT INTO Tbl_Party (DATE_PARTY, TIME_PARTY_START, TIME_PARTY_END) " & _ "VALUES (#" & Me.DATE_PARTY & "#, #" & Me.TIME_PARTY_START & "#, #" & Me.TIME_PARTY_END & "#)", dbFailOnError MsgBox "تم حفظ الحجز بنجاح!", vbInformation, "تأكيد" End If rs.Close: Set rs = Nothing End Sub WEEDING HALLS.accdb

عندي انا يعمل 100% في شيت الاول لا تعمل اي شيء البرنامج يعمل تسطير من تلقاء نفسه مع بدء كتابة في صف جديد عملت لك فلاتر اذا حبيت تصدير بين تاريخين ، اكتب تاريخين " من الى" ثم اضغط على زر فلتر ما فهمت قصك بضبط ، حاليا كيو آركود موجو في عمود M و نص كيوآركود من عمود I في نفس صف، و يعمل كماهو على كل حال انت جرب المرفق و شوف نتيجة أنشطة 2025 (A).xlsb

اشكركم تم حل الموضوع وأعتذر عن انشغالي بالتأخر بالرد

جرب المرفق التالي BAR_1.mdb قم بمسح الاقتطاعات السابقة

باعتقادي وبأنه الكثير لم يفهم تسلسل ولا آلية ولا فكرة المرفق أو كيفية فهم النتائج في هذا المشروع ، اعتقد إنه يتوجب عليك أخي @طاهر اوفيسنا إعادة النظر في الآلية التي تسير بها في مشروعك . هذا من ناحية طبعاً . من ناحية أخرى ما زلت تفتقر الى الشرح المبسط أو الواضح وتوصيل المعلومة التي من خلالها نستطيع فهم ما تريده . وليس تزويدنا بكود وصورة قد يكون كافياً دائماً لفهم المطلوب . على العموم ، جرب هذا التعديل في النهج كاملاً .. Private Sub cmd_Pay_installments_Click() On Error GoTo err_cmd_Pay_installments_Click Dim rst As DAO.Recordset Dim rstE As DAO.Recordset Dim Rc As Integer, TheSum As Double Dim myCriteria As String Set rst = CurrentDb.OpenRecordset("SELECT * FROM tbl_Loans WHERE [Payment_Month]=#" & Format(Me.txtMonth, "mm/dd/yyyy") & "#") If rst.EOF Then MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.txtMonth, "mmmm yyyy"), vbInformation rst.Close: Set rst = Nothing Exit Sub End If With rst If IsNull(!Payment_Made) And Not IsNull(!Loan_Made) Then If MsgBox("هل تريد توزيع الإقتطاعات لشهر " & Format(Me.txtMonth, "mmmm yyyy") & "؟", vbYesNo + vbQuestion) = vbYes Then Do Until .EOF .Edit If !Nr >= 6 Then !Payment_Made = 0 ElseIf !Loan_Type = "Cridi" Or !Loan_Type = "Elec" Then !Payment_Made = !Loan_Made !sadad = !Loan_Made !Loan_Remise = 0 End If !wada3 = IIf(Nz(!sadad, 0) <> 0, "تم التسديد", "لم يتم التسديد") TheSum = TheSum + Nz(!Payment_Made, 0) .Update .MoveNext Loop ' اقتطاع الانخراط في مارس ويوليو If Month(Me.txtMonth) = 3 Or Month(Me.txtMonth) = 7 Then myCriteria = "([detach] IN ('موظف', 'عامل متعاقد توقيت كامل', 'عامل متعاقد توقيت جزئي', 'حارس متعاقد توقيت جزئي', 'عون نظافه وتطهير'))" Set rstE = CurrentDb.OpenRecordset("SELECT * FROM Employee WHERE " & myCriteria) If Not rstE.EOF Then Do Until rstE.EOF If DCount("*", "tbl_Loans", "EmployeeID=" & rstE!EmployeeID & " AND [Loan_Type]='Inkhirat' AND [Payment_Month]=#" & Me.txtMonth & "#") = 0 Then .AddNew !EmployeeID = rstE!EmployeeID !Loan_ID = 0 !Payment_Month = Me.txtMonth !Payment_Made = DLookup("Other_Value", "TblOther", "ID=1") !Loan_Type = "Inkhirat" !Nr = GetNumDetach(rstE!EmployeeID) !Remarks = "إقتطاع من الراتب لإنخراط شهر " & Format(Me.txtMonth, "yyyy/mm") !sadad = !Payment_Made !wada3 = "تم الإنخراط" .Update TheSum = TheSum + Nz(!Payment_Made, 0) End If rstE.MoveNext Loop End If rstE.Close: Set rstE = Nothing End If ' عرض المجموع النهائي MsgBox "تم توزيع الإقتطاعات بنجاح." & vbCrLf & "المجموع: " & Format(TheSum, "#,##0.00"), vbInformation, "إقتطاعات شهر " & Format(Me.txtMonth, "mmmm yyyy") End If End If End With rst.Close: Set rst = Nothing Exit Sub err_cmd_Pay_installments_Click: MsgBox "خطأ رقم: " & Err.Number & vbCrLf & Err.Description, vbCritical If Not rst Is Nothing Then rst.Close: Set rst = Nothing If Not rstE Is Nothing Then rstE.Close: Set rstE = Nothing End Sub الكود في ملف نصي مضغوط .. Text_VBA.zip

الطريقة تعتمد على النت لنقل البيانات ولا بد أن يكون لكل شخص من أعضاء الفريق الذي سيدخل البيانات (وكذلك المسؤول) بريد الكتروني على قوقل , والطريقة وهي : 1 إنشاء قوقل فورم الذي من خلاله سيتم ادخال البيانات من الجوال 2 إنشاء ملف قوقل شيت في بريد Gmail وربطه بقوقل فورم 3 إنشاء ملف اكسل على جهاز (الكنج المسؤوول) حتى يتم تجميع كل البيانات عنده ==================== أستطيع عمل الخطوات الثلاثة على حسابي gmail كتجربة بحيث أكون أنا المسؤول أو أجعل المسؤول هو أحد فريق عملكم وهنا لابد أن يتواصل معي حتى يفهم كيفية عمل كل ما سبق التواصل على حسابي Gmail 8abo.eed8@gmail.com

أسأل الله ان ينور دربكم ويوفقكم شكرا لكم جميعا

السلام عليكم نم تعديل كود خفظ الشهادة يحيت يحفظ باسم الفصل والشعبة حسب ما هو مكتوب في الخليتين b6&b7 ولم يعد التغيير من الكود لم افهم قصدك بمحاولة التعديل على كود الترتيب اذا كان المقصود كلمة مكرر ينم الغائها فالملف المرفق فيه طلبك وان كنل تعنى شئ اخر فاوضح لي الامر ترتيب التلاميذ تصاعديا (1) - Copy.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اقتراحات من الممكن أن تستفيد منها سواءا للترتيب أو حفظ الملف Sub ExportToPDF() Dim endNum As Long, wb As Workbook, WS As Worksheet, i As Long Dim nFichier As String, chemin As String, r As String, n As Integer Set WS = Sheets("الشهادة") If IsEmpty(WS.Range("H2").Value) Then MsgBox "الرجاء تحديد إجمالي الشهادات", vbExclamation: Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False startNum = WS.[F2].Value: endNum = WS.[H2].Value Set wb = Workbooks.Add(xlWBATWorksheet) chemin = ThisWorkbook.Path & "\الشهادات\" If Len(Dir(chemin, vbDirectory)) = 0 Then MkDir chemin nFichier = WS.[B6].Value & "_" & WS.[B7].Value & ".pdf" r = chemin & nFichier If Len(Dir(r)) > 0 Then n = 1 Do r = chemin & WS.[B6].Value & "_" & WS.[B7].Value & "(" & n & ").pdf" n = n + 1 Loop Until Len(Dir(r)) = 0 End If For i = 1 To endNum WS.[F2].Value = i WS.Copy After:=wb.Worksheets(wb.Worksheets.Count) Next i WS.[F2].Value = 1 wb.Worksheets(1).Delete wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=r wb.Close False .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True End With MsgBox "تم تصدير الشهادات بنجاح في " & vbCrLf & vbCrLf & _ r, vbInformation, "تم حفظ الشهادات من " & startNum & " إلى " & endNum End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B7:S36")) Is Nothing Then Dim WS As Worksheet, i As Long, j As Long, n As Long, ky As Long, a() As Variant, tmp As Long, tbl As String Set WS = ActiveSheet Application.ScreenUpdating = False WS.Range("Y7:AA36").ClearContents For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 Next i If tmp = 0 Then MsgBox "لا توجد بيانات", vbExclamation: Exit Sub ReDim a(1 To tmp, 1 To 3) tmp = 0 For i = 7 To 36 If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _ Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1 a(tmp, 1) = WS.Cells(i, "A").Value: a(tmp, 2) = WS.Cells(i, "B").Value: a(tmp, 3) = WS.Cells(i, "S").Value End If Next i For i = 1 To tmp - 1 For j = i + 1 To tmp If a(i, 3) < a(j, 3) Then r a(i, 1), a(j, 1): r a(i, 2), a(j, 2): r a(i, 3), a(j, 3) End If Next j Next i n = 1: ky = 1 WS.Cells(7, "Y").Value = 1: WS.Cells(7, "Z").Value = a(1, 2): WS.Cells(7, "AA").Value = "الأول" For i = 2 To tmp If a(i, 3) = a(i - 1, 3) Then ky = ky + 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl Else n = n + 1: ky = 1 tbl = GetTex(n, ky) WS.Cells(i + 6, "AA").Value = tbl End If WS.Cells(i + 6, "Y").Value = i: WS.Cells(i + 6, "Z").Value = a(i, 2) Next i Application.ScreenUpdating = True End If End Sub Sub r(ByRef a As Variant, ByRef b As Variant) Dim temp As Variant temp = a: a = b: b = temp End Sub Function GetTex(n As Long, ky As Long) As String GetTex = tmps(n) & IIf(ky > 1, " " & ky, "") End Function ترتيب التلاميذ تصاعديا V2.xlsm

تحياتي لحضرتك تمام الله ينور ويرضى عليك وعلى والديك تم التجريب وتفكيك الكود الحمدلله هو ده المطلوب سلمك الله

فقط عليك استخدام هذه المعادلة =MIN(A2:B2) تواريخ1.xlsx