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

السلام عليكم ورحمه الله وبركاته مشاركه مع اخى @محمد احمد لطفى جزاه الله خيرا اتفضل Private Sub Commande3_Click() Dim rs As Recordset Set rs = Me.Table1sub.Form.RecordsetClone For i = 0 To rs.RecordCount - 1 If Len(rs.Fields("date a") & "") = 0 Then rs.Edit rs.Fields("date a") = Date rs.Update End If rs.MoveNext Next rs.Close Set rs = Nothing End Sub وبالنسبه لما ذكره اخى محمد فالنموذج ليس به مشكله ولكن تقريبا اخى رشيد يستخدم اللغه الفرنسيه بجهازه فلذلك لم يعمل معك ومعى ايضا واحسنت بالاستيراد والتعديل بالتوفيق اخوانى

ربنا يبارك فى حضرتك و يحفظك

نفس الكود طبقه على التقارير تفضل هذا مثال مثال.accdb

وعليمن السلام بالإذن خيار آخر Sub test() Dim a, b: Dim lr& a = ActiveSheet.Range("D6:D14").Resize(, 4) ReDim b(1 To 5) b = Array(1, 3, 5, 7, 9) Workbooks.Open ("C:\Users\Ehab Elhady\Desktop\1.xlsx") With Sheets("sheet1").Cells(1, 1).Resize(, 5) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Offset(lr).Value = Application.Index(a, b, 1) .Offset(lr, 5).Value = Application.Index(a, b, 4) End With Workbooks("1.xlsx").Close True End Sub

أهلا @محمد احمد لطفى أرجو لك مزيدا من التقدم والتوفيق.. إليك التعديل تعليمى (1).mdb

وعليكم السلام ورحمه الله وبركاته For Each w In ThisWorkbook.Worksheets If w.Name <> "ورقة7" And w.Name <> "ورقة8" Then co1.AddItem w.Name End If Next w

طيب جرب هذا baset2.accdb

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

لإخفاء الشريط السفلي و تحويل العناصر من اليمني الى اليسار اذهب الى خيارات

طيب اتفضل هذا رغم اني حتى الآن فكرتك ما وصلتني يعني ما فهمت طلبك بالضبط لكن شوف هذا التعديل ادخل على النموذج يعني افتح التقرير من النموجذ يا تختار الرقم او تختار الرقم و الإسم baset2.accdb

تفضل أخي عبد القدوس .. ممكن تعملها عن طريق التنسيق الشرطي 🙂 : والنتيجة ( لا يمكن تحرير البيانات ..... وتبقى مجمدة حتى يتم تغيير خانة مشطوب) : قاعدة البيانات.accdb

جزاك الله خيرا استاد ابوبسمله نعم هدا ما اريد بالظبط

تفضل هذا التعديل baset2.accdb لم افهم هذا الطلب و ضح بزيادة عندي شعور بإننا بدينا نوصل للحل الله يسهل الحال

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Option Explicit Sub Transfer() Dim wbData As Workbook, wsData As Worksheet Dim rngToCopy As Range, cl As Range Dim C As Long, LastRow As Long Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.ActiveSheet Application.ScreenUpdating = False Set wbData = Workbooks.Open("C:\Users\Ehab Elhady\Desktop\1.xlsx") Set wsData = wbData.Sheets("Sheet1") Set rngToCopy = wsMain.Range("D6,D8,D10,D12,D14,G6,G8,G10,G12,G14") LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row C = 1 For Each cl In rngToCopy cl.Copy wsData.Cells(LastRow + 1, C).PasteSpecial xlPasteValues C = C + 1 Next cl wbData.Close True Application.CutCopyMode = False MsgBox " تم ترحيل البيانات بنجاح", vbInformation, "تعليمات" End Sub e_V2.rar

اخي الحبيب خليفة ما فهمته بناءا علي ما قرأته وهو اذا رغبت في وضع الكود الموضوع تحت زر الامر " اعادة التحجيم " في حدث عند الفتح او التحميل فلا يوجد مشكله . نضع هذا الحدث في النموذج عند الفتح On Error Resume Next ReSizeForm Me 'اعادة تحجيم النموذج الرئيسي ReSizeForm subForm.Form 'اعادة تحجيم النموذج الفرعي Me.cmdClose.SetFocus Me.cmdResize.Enabled = False ثم ننسخ الوحدة النمطية هذه الي قاعدة البيانات Option Compare Database Option Explicit 'قم بتغيير الارقام بناء على دقة الشاشة التي سوف تستخدمها للعرض مثلا 640 × 480 او 800 × 600 او 1024 × 768 بيكسل Private Const DESIGN_HORZRES As Long = 640 Private Const DESIGN_VERTRES As Long = 480 'مقدار عدد البكسلات في البوصة الواحده 96 يفضل تركه كما هو لانه قياسي Private Const DESIGN_PIXELS As Long = 96 Private Const WM_HORZRES As Long = 8 Private Const WM_VERTRES As Long = 10 Private Const WM_LOGPIXELSX As Long = 88 Private Const TITLEBAR_PIXELS As Long = 18 Private Const COMMANDBAR_PIXELS As Long = 26 Private Const COMMANDBAR_LEFT As Long = 0 Private Const COMMANDBAR_TOP As Long = 1 Private OrigWindow As tWindow Private Type tRect left As Long Top As Long right As Long bottom As Long End Type Private Type tDisplay Height As Long Width As Long DPI As Long End Type Private Type tWindow Height As Long Width As Long End Type Private Type tControl Name As String Height As Long Width As Long Top As Long left As Long End Type Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _ (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" _ () As Long Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" _ (ByVal hwnd As Long) As Long Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" _ (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function WM_apiGetWindowRect Lib "user32.dll" Alias "GetWindowRect" _ (ByVal hwnd As Long, lpRect As tRect) As Long Private Declare Function WM_apiMoveWindow Lib "user32.dll" Alias "MoveWindow" _ (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal bRepaint As Long) As Long Private Declare Function WM_apiIsZoomed Lib "user32.dll" Alias "IsZoomed" _ (ByVal hwnd As Long) As Long 'الغرض من هذه الوظيفة هو احضار معلومات الطول والعرض والبيكسل الحالي لشاشة العرض Private Function getScreenResolution() As tDisplay Dim hDCcaps As Long Dim lngRtn As Long On Error Resume Next hDCcaps = WM_apiGetDC(0) With getScreenResolution .Height = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES) .Width = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES) .DPI = WM_apiGetDeviceCaps(hDCcaps, WM_LOGPIXELSX) End With lngRtn = WM_apiReleaseDC(0, hDCcaps) End Function 'الغرض من هذه الوظيفة هو اعادة قيم عناصر النموذج كاملة في الطول والعرض وتكبيرها حسب مقاس الشاشة الحالية Private Function getFactor(blnVert As Boolean) As Single Dim sngFactorP As Single On Error Resume Next If getScreenResolution.DPI <> 0 Then sngFactorP = DESIGN_PIXELS / getScreenResolution.DPI Else sngFactorP = 1 End If If blnVert Then getFactor = (getScreenResolution.Height / DESIGN_VERTRES) * sngFactorP Else getFactor = (getScreenResolution.Width / DESIGN_HORZRES) * sngFactorP End If End Function 'الغرض من هذه الوظيفة هي القيام بإستدعاءها في حدث عند الفتح وعند التحميل Public Sub ReSizeForm(ByVal frm As Access.Form) Dim rectWindow As tRect Dim lngWidth As Long Dim lngHeight As Long Dim sngVertFactor As Single Dim sngHorzFactor As Single Dim sngFontFactor As Single On Error Resume Next sngVertFactor = getFactor(True) sngHorzFactor = getFactor(False) sngFontFactor = VBA.IIf(sngHorzFactor < sngVertFactor, sngHorzFactor, sngVertFactor) Resize sngVertFactor, sngHorzFactor, sngFontFactor, frm If WM_apiIsZoomed(frm.hwnd) = 0 Then Access.DoCmd.RunCommand acCmdAppMaximize Call WM_apiGetWindowRect(frm.hwnd, rectWindow) With rectWindow lngWidth = .right - .left lngHeight = .bottom - .Top End With If frm.Parent.Name = VBA.vbNullString Then Call WM_apiMoveWindow(frm.hwnd, ((getScreenResolution.Width - _ (sngHorzFactor * lngWidth)) / 2) - getLeftOffset, _ ((getScreenResolution.Height - (sngVertFactor * lngHeight)) / 2) - _ getTopOffset, lngWidth * sngHorzFactor, lngHeight * sngVertFactor, 1) End If End If Set frm = Nothing End Sub 'الغرض من هذه الوظيفة هي اعادة تحجيم مقاسات الاقسام الخاصة بالنموذج مثل قسم تفصيل وقسم رأس النموذج وتذييل النموذج Private Sub Resize(sngVertFactor As Single, sngHorzFactor As Single, sngFontFactor As _ Single, ByVal frm As Access.Form) Dim ctl As Access.Control Dim arrCtls() As tControl Dim lngI As Long Dim lngJ As Long Dim lngWidth As Long Dim lngHeaderHeight As Long Dim lngDetailHeight As Long Dim lngFooterHeight As Long Dim blnHeaderVisible As Boolean Dim blnDetailVisible As Boolean Dim blnFooterVisible As Boolean Const FORM_MAX As Long = 31680 On Error Resume Next With frm .Painting = False lngWidth = .Width * sngHorzFactor lngHeaderHeight = .Section(Access.acHeader).Height * sngVertFactor lngDetailHeight = .Section(Access.acDetail).Height * sngVertFactor lngFooterHeight = .Section(Access.acFooter).Height * sngVertFactor .Width = FORM_MAX .Section(Access.acHeader).Height = FORM_MAX .Section(Access.acDetail).Height = FORM_MAX .Section(Access.acFooter).Height = FORM_MAX blnHeaderVisible = .Section(Access.acHeader).Visible blnDetailVisible = .Section(Access.acDetail).Visible blnFooterVisible = .Section(Access.acFooter).Visible .Section(Access.acHeader).Visible = False .Section(Access.acDetail).Visible = False .Section(Access.acFooter).Visible = False End With ReDim arrCtls(0) For Each ctl In frm.Controls If ((ctl.ControlType = Access.acTabCtl) Or _ (ctl.ControlType = Access.acOptionGroup)) Then With arrCtls(lngI) .Name = ctl.Name .Height = ctl.Height .Width = ctl.Width .Top = ctl.Top .left = ctl.left End With lngI = lngI + 1 ReDim Preserve arrCtls(lngI) End If Next ctl For Each ctl In frm.Controls If ctl.ControlType <> Access.acPage Then With ctl .Height = .Height * sngVertFactor .left = .left * sngHorzFactor .Top = .Top * sngVertFactor .Width = .Width * sngHorzFactor .FontSize = .FontSize * sngFontFactor Select Case .ControlType Case Access.acListBox .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor) Case Access.acComboBox .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor) .ListWidth = .ListWidth * sngHorzFactor Case Access.acTabCtl .TabFixedWidth = .TabFixedWidth * sngHorzFactor .TabFixedHeight = .TabFixedHeight * sngVertFactor End Select End With End If Next ctl For lngJ = 0 To lngI With frm.Controls.Item(arrCtls(lngJ).Name) .left = arrCtls(lngJ).left * sngHorzFactor .Top = arrCtls(lngJ).Top * sngVertFactor .Height = arrCtls(lngJ).Height * sngVertFactor .Width = arrCtls(lngJ).Width * sngHorzFactor End With Next lngJ With frm .Width = lngWidth .Section(Access.acHeader).Height = lngHeaderHeight .Section(Access.acDetail).Height = lngDetailHeight .Section(Access.acFooter).Height = lngFooterHeight .Section(Access.acHeader).Visible = blnHeaderVisible .Section(Access.acDetail).Visible = blnDetailVisible .Section(Access.acFooter).Visible = blnFooterVisible .Painting = True End With Erase arrCtls Set ctl = Nothing End Sub 'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليمين ووضع النموذج في منتصف الشاشة Private Function getTopOffset() As Long Dim cmdBar As Object Dim lngI As Long On Error GoTo err For Each cmdBar In Application.CommandBars If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_TOP)) Then lngI = lngI + 1 End If Next cmdBar getTopOffset = (TITLEBAR_PIXELS + (lngI * COMMANDBAR_PIXELS)) exit_fun: Exit Function err: getTopOffset = TITLEBAR_PIXELS + COMMANDBAR_PIXELS Resume exit_fun End Function 'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليسار ووضع النموذج في منتصف الشاشة Private Function getLeftOffset() As Long Dim cmdBar As Object Dim lngI As Long On Error GoTo err For Each cmdBar In Application.CommandBars If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_LEFT)) Then lngI = lngI + 1 End If Next cmdBar getLeftOffset = (lngI * COMMANDBAR_PIXELS) exit_fun: Exit Function err: getLeftOffset = 0 Resume exit_fun End Function 'الغرض من هذه الوظيفة هو اعادة تحجيم كامل عرض الاعمدة وعدم ترك فراغات من الناحية اليسرى Private Function adjustColumnWidths(strColumnWidths As String, sngFactor As Single) As String On Error GoTo Err_adjustColumnWidths Dim astrColumnWidths() As String Dim strTemp As String Dim lngI As Long Dim lngJ As Long ReDim astrColumnWidths(0) For lngI = 1 To VBA.Len(strColumnWidths) Select Case VBA.Mid(strColumnWidths, lngI, 1) Case Is <> ";" astrColumnWidths(lngJ) = astrColumnWidths(lngJ) & VBA.Mid( _ strColumnWidths, lngI, 1) Case ";" lngJ = lngJ + 1 ReDim Preserve astrColumnWidths(lngJ) End Select Next lngI lngI = 0 strTemp = VBA.vbNullString Do Until lngI > UBound(astrColumnWidths) If Not IsNull(astrColumnWidths(lngI)) And astrColumnWidths(lngI) <> "" Then strTemp = strTemp & CSng(astrColumnWidths(lngI)) * sngFactor & ";" End If lngI = lngI + 1 Loop adjustColumnWidths = strTemp Erase astrColumnWidths Exit_adjustColumnWidths: On Error Resume Next Exit Function Err_adjustColumnWidths: Erase astrColumnWidths 'Destroy array. Resume Exit_adjustColumnWidths End Function 'الغرض من هذه الوظيفة اعادة حجم النموذج الى وضعه الطبيعي قبل اعادة التحجيم ويتم استدعاؤها عن تحميل النموذج Public Sub getOrigWindow(frm As Access.Form) On Error Resume Next OrigWindow.Height = frm.WindowHeight OrigWindow.Width = frm.WindowWidth End Sub 'الغرض من هذه الوظيفة هو اعادة مقاس النموذج الى وضعه الطبيعي عند حدث الاغلاق Public Sub RestoreWindow() On Error Resume Next Access.DoCmd.MoveSize , , OrigWindow.Width, OrigWindow.Height Access.DoCmd.Save End Sub هل فهمي لامر صحيح هكذا اخي

تفضل أخي هذه المشاركة للأخت زهره العبد الله جزاها الله كل الخير .

مين قال ان حضرتك لم تتمكن من ايصال المعلومة تبارك الله لا قوة الا بالله شرح حضرتك وافي وكافي وبارك الله فيك اخي لقد فهمت الان ووصلت الفكرة

تفضل طلبك و لا تنساني بدعوة طيبة مثال.accdb

تفضل اخي هدا حل اخر على حسب ما فهمت من اخر ملف قمت برفعه تمت اظافة شيت جديد باسم النتائج لاستخراج تقرير كل اسبوع على حده تحت بعض في ورقة واحدة كما في الصورة ادناه . شيت النتائج مع استخراج بيانات كل اسبوع في شيت مستقل بدون تكرار للتواريخ . وحفظ الكل في مجلد في بارتشن (E) فرز بيانات V2.rar

تفضل ملف متابعة.xlsm

استخدم هذه الجملة في استعلام SELECT t1.id, t1.CurrencyType, t1.Credit, t1.Debit, (SELECT SUM(t2.Credit - t2.Debit) FROM trans t2 WHERE t2.CurrencyType = t1.CurrencyType AND (t2.id <= t1.id)) AS CumulativeBalance, t1.id FROM trans AS t1 ORDER BY t1.id; غير trans حسب اسم الجدول لديك

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm

السلام عليكم معلومة في اكسس / دالة Sum / الاجمالي او المجموع مرفق قاعدة البيانات اتمنى لك مالفائدة لا تحرمونا من الدعاء العدد والمجموع.accdb

السلام عليكم ورحمة الله وبركاته يمكنك تحويل التقرير إلى pdf ومن ثم عند الطباعة تحدد الطابعة وتحدد حجم الورقة كود التحويل إلى pdf DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF, , True حيث ReportName هو اسم التقرير