علي المصري

تم اضافة مربع نص في النموذج تكتب فيه الرمز او العلامة التي تريد فصل الاسم عندها sdd.rar

افتح التقرير في وضع التصميم في الدزء الخاص ب Details ـو تفصيل باللغة العربية حدث عند التنسيق on format ضع الكود If [txtcounter] Mod 2 = 0 Then Me.Detail.ForceNewPage = 2 Else Me.Detail.ForceNewPage = 0 End If shsh.rar

تفضل مثال Database4.rar

لاحظ ان الحق الموجود مقبل هذا اليوم في التقرير يعطي خطأ سوف اجرب مرة ثانية إن شاء الله

ممكن اربط ال option group بحقل واحد في الجدول او أنا لم افهم جيدا الموضوع او محتوى المطلوب شكرا جزيلا

الحمد لله تم معرفة مكان الخطأ في الكود وتم اصلاحه شكرا جزيلا

حل آخر باستخدام Option Group test.rar

لو سمحت ارفق نموذج من البرنامج

من فضلك احذف احد ايام الشهر وافتح التقرير ماذا تلاحظ

اذا اردت تغيير الاسم الافتراضي عيره داخل الكود وليس عند الحفظ

فقط ادخل إلى الكود وغير * إلى /

تفضل db3_1.rar

استخدم الكود كما يلي On Error Resume Next DoCmd.OutputTo acOutputTable, "Table1", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Table2", "Table1.xlsx", True, sheet2 DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Table3", "Table1.xlsx", True, sheet3 يمكنك اضفة سطر رابع مع الجدول رقم 3 وسطر خامس مع الجدول التالي وهكذا مع تغيير table3 ب table4 وهكذا وتغيير رقم الشيت sheet3 إلى sheet4 وهكذا ولا تغير اسم الملف Table1.xlsx تلاحظ انه نفس الاسم في السطور الثلاث وهذا يعني اننا نقول لكود قم بتصدير الجداول الثلاثة إلى نفس الملف واذا ار\ت تغييرة باسم آخر فقط غير كلمة Table1 بالاسم الذي تريده مثلا AliElmasry.xlsx

نموذج تطبيقي ExportToExcel&Pdf.rar

تفضل اخي الكريم طلبك sdd.rar

يعني حضرتك لا تريد عملية الفلترة ايضا

باستخدام احد الأكواد التالية يمكنك تصدير جدولين إلى ملف اكسيل واحد كل جدول في ورقة حيث Table1 و Table2 هي اسماء الجداول DoCmd.OutputTo acOutputTable, "Table1", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Table2", "Table1.xlsx", True, sheet2 أو استخدم الكود التالي Dim Filepath As String Filepath = CurrentProject.Path & "\StudentData.xlsx" DoCmd.TransferSpreadsheet acExport, , "Table1", Filepath, True, sheet1 DoCmd.TransferSpreadsheet acExport, , "Table2, Filepath, True, sheet2 حيث أنه سوف يتم الحفظ في نفس مسار قاعدة البيانات باسم studentsData يمكنك تغييره كما تحب

تفضل استاذنا الفاضل جرب ما يلي حيث Table1 و Table2 هي اسماء الجداول DoCmd.OutputTo acOutputTable, "Table1", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Table2", "Table1.xlsx", True, sheet2 أو استخدم الكود التالي Dim Filepath As String Filepath = CurrentProject.Path & "\StudentData.xlsx" DoCmd.SetWarnings False DoCmd.TransferSpreadsheet acExport, , "Table1", Filepath, True, sheet1 DoCmd.TransferSpreadsheet acExport, , "Table2, Filepath, True, sheet2 حيث أنه سوف يتم الحفظ في نفس مسار قاعدة البيانات باسم studentsData يمكنك تغييره كما تحب

إذا اردت ان تجمعهم في ورقة واحدة ما عليك إلى ضم الجدولين عن طريق عمل استعلام معتمد على الجدولين ثم قم بتصدير الاستعلام كالتالي DoCmd.OutputTo acOutputQuery, "QueryName", "ExcelWorkbook(*.xlsx)", "", True, "", , acExportQualityPrint

استخدم الكود التالي DoCmd.OutputTo acOutputTable, "Table1", "ExcelWorkbook(*.xlsx)", _ "", True, "", , acExportQualityPrint DoCmd.OutputTo acOutputTable, "Table2", "ExcelWorkbook(*.xlsx)", _ "", True, "", , acExportQualityPrint استبدل Table1 و Table2 باسمي الجدولين لديك

هي يمكن التعديل بحيث يخرج مربع حواري تختار منه المكان الذي تريد الحفظ فيه شكرا

تفضل اخي الكريم db3_1.rar

في وضع التصميم تبويب Others امام Shortcut Menu اجعل القيمة No

السلام عليكم ورحمة الله وبركاته انا بستخدم الكود التالي مع الوظيفة المعرفة انسخ الكود التالي مع تغيير اسماء الاوارق حسب ما هو موجود عندك sub SavePdf() On Error Resume Next Dim FileName As String Dim rng As Range On Error Resume Next Set rng = Range(Sheets("AliElbasry").PageSetup.PrintArea) If Not rng Is Nothing Then Debug.Print rng.Address(external:=True) rng.Select FileName = RDB_Create_PDF(Sheets("AliElbasry"), "", True, True) If FileName = "" Then Else Sheets("Data").Select Range("D3:L3").Select Exit Sub End If End If Sheets("Data").Select Range("D3:L3").Select End Sub   مع الوظيفة التالية انسخ وضوعها في موديول جديد Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _ OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String Dim FileFormatstr As String Dim Fname As Variant If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _ & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then If FixedFilePathName = "" Then FileFormatstr = "PDF Files (*.pdf), *.pdf" Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _ Title:="Create PDF") If Fname = False Then Exit Function Else Fname = FixedFilePathName End If If OverwriteIfFileExist = False Then If Dir(Fname) <> "" Then Exit Function End If On Error Resume Next Myvar.ExportAsFixedFormat _ Type:=xlTypePDF, _ FileName:=Fname, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=OpenPDFAfterPublish On Error GoTo 0 If Dir(Fname) <> "" Then RDB_Create_PDF = Fname End If End Function

شكرا لك وجزاك الله خير على الاهتمام سيتم التنفيذ والتجربة ان شاء الله