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

هذه هي المكتبة المطلوبة

وعليكم السلام Private Sub cm_ToExcel_Click() On Error GoTo Err_cm_ToExcel_Click Dim stDocName As String Dim Q As Integer Dim sh As Object Dim folder As Object Dim FolderPath As String Dim FilePath As String stDocName = "tbl_Teacher_" & [Year_name] Q = DCount("*", "tbl_Teacher") If Q > 0 Then ' اختيار مجلد Set sh = CreateObject("Shell.Application") Set folder = sh.BrowseForFolder(0, "اختر مجلد حفظ الملف", 0) ' لو إلغاء If folder Is Nothing Then Exit Sub FolderPath = folder.Items().Item().Path FilePath = FolderPath & "\" & stDocName & ".xls" ' 🔥 التحقق من وجود الملف If Dir(FilePath) <> "" Then If MsgBox("الملف موجود بالفعل:" & vbCrLf & FilePath & vbCrLf & vbCrLf & _ "هل تريد استبداله؟", _ vbYesNo + vbQuestion + vbMsgBoxRight, "تأكيد") = vbNo Then Exit Sub End If End If ' التصدير DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", FilePath, False MsgBox "تم حفظ الملف بنجاح في:" & vbCrLf & FilePath, vbInformation + vbMsgBoxRight, "تم" Else MsgBox "لا يوجد سجلات لتصديرها", vbExclamation + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: Exit Sub Err_cm_ToExcel_Click: MsgBox Err.Description Resume Exit_cm_ToExcel_Click End Sub

أنت هنا تريد أتمتة عمل مرتبط بعمل خارج نطاق التطبيق بمعنى أنت لاتعلم ماذا سيكون رقم الدفتر الجديد هل هو الرقم التالي أم رقم سابق كان قد تم السهو عنه من قبل امين الصندوق أو أو أو .... هذا يعني أن إحتمالات المتغيرات الخارجية ستكون كثيرة لذا فأفضل خيار لديك هو أن تجعل البرنامج يقوم بقراءة آخر إيصال والإحتفاظ بآخر رقمين منه ثم إضافتهما لرقم الإيصال الجديد وللحصول على النتيجة وفق طلبك هذا قمت بتعديل ملفك الأصلي للحصول على هذه النتيجة - عند إدخال رقم الإيصال سيقوم النموذج بالتعامل معه بناءاً على الرقم - إذا كان أقل من أو يساوي 1000 سيتم إرجاع رقم آخر إيصال تم إدخاله وإضافته للرقم الذي قمت بإدخاله (عندما يكون 1000 سيبدأ الدفتر التالي) - قد تضطر أحيانا لتصحيح رقم إيصال كنت قد أدخلته بالغلط عندها يمكنك إدخال الرقم كاملاً (5 أرقام أي أكبر من 1000) عندها سيتم الإحتفاظ بالرقم كما أدخلته - إذا صادف وتم بدء العمل بدفتر برقم سابق أو ليس الرقم الذي يلي الرقم الحالي عندها ستكون مضطر لإدخال الرقم كاملا (أو تصحيح الرقم) لأول إيصال فقط وبعدها سيتم التعامل مع هذا الرقم الجديد - جرب إجراء كل التعديلات التي يمكن أن تواجهها في العمل وتأكد من أن النتائج ستكون مطابقة للنتائج المرجوة منها أم لا Lab.accdb

جرب هذا Dim result As VbMsgBoxResult result = MsgBox("ماذا تريد ان تفعل اضغط Yes لفتح النموذج NO لفتح التقرير Cancel للتراجع" & vbCrLf & vbCrLf & "الحمدلله", _ vbYesNoCancel + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "الله المستعان") If result = vbYes Then DoCmd.OpenForm "22" ElseIf result = vbNo Then DoCmd.OpenReport "33", acViewPreview ElseIf result = vbCancel Then Exit Sub ' 👈 هنا يخرج بدون أي إجراء End If

نعم الموقع ثقة ، وانا اشرت الى هذا في الرابط التالي ، وهناك رد من الاخ @محمد سلامة عن طريقة لا اعرفها:

اليكم الشرح والمرفق . DD13901390-1.rar

شكرا جزيلا أخي الفاضل وبارك الله فيك

السلام عليكم و رحمة الله استخدم هذا الكود Sub TranData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Integer, Arr Set ws = Sheets("استلام مبلغ") Set Sh = Sheets("جمع المبالغ") ActiveWindow.SelectedSheets.PrintOut from:=1, to:=1, copies:=1 LR = Sh.Range("C" & Rows.Count).End(3).Row Arr = Array("B7", "B6", "E4", "D6", "A8") For i = LBound(Arr) To UBound(Arr) Sh.Range("B" & LR + 1).Offset(0, i) = ws.Range(Arr(i)) Next End Sub