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

تفضل اخي الكريم هذا الكود لتحويل التقرير إلى صيغة pdf Private Sub أمر65_Click() Dim varItem As Variant Dim myWhere As String Dim Criteria As String Dim ReportName As String ReportName = "rap_liste_stagiere_grade_groupe1" Criteria = varItem myWhere = "" ' Loop through the selected items in the ListBox For Each varItem In Me.lst_XX.ItemsSelected ' Add each selected item to the string myWhere = myWhere & "'" & Me.lst_XX.ItemData(varItem) & "', " Next varItem ' Remove the trailing comma and space from the string myWhere = Left(myWhere, Len(myWhere) - 2) DoCmd.OpenReport "rap_liste_stagiere_grade_groupe1", acViewPreview, , "[grade] in (" & myWhere & ")" DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF DoCmd.Close acReport, ReportName, acSaveNo End Sub نفس الكود تستطيع ان تستخدمه في طباعة التقرير مع تغير بسيط في هذا السطر DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF بالتوفيق

اتفضل Show Report On Form.accdb

الملف خالي من الاكواد مع عدم دكر عمود او معيار الفلترة

السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" 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 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb

لتعم الفائدة بشكل اكبر وتصل للجميع سارفق لكم ملف مضغوط فيه كل اسماء الأوامر والازرار الموجودة في مجموعة الاوفيس ، وطريقة استخدامها في xml على الشكل التالي <control idMso="ExportExcel" label="Export to Excel" enabled="true"/> اما المجموعات تضاف باستخدام المجموعة والتاب باستخدام التاب وهكذا كما هو متعارف عليه في xml Office2013FluentUserInterfaceControlIdentifiers.zip

جرب هذه الطريقة : BASEB.accdb

بارك الله فيك أخي الكريم وجعله الله في ميزان حسناتك هذا ما أريده بالضبط

هذا ما اتعلمه انا وكل طلاب العلم منكم ومن باقى اساتذتى الكرام جزاكم الله عنا كل خيــــــــر

وعليكم السلام ورحمة الله تعالى وبركاته طيب فكرتى المتواضعة لو اعجبتك سوف أقوم بعمل بعض التعديلات اللازمة لاضفاء مرونة اكثر BASEB (Judy).accdb

أستاذي ومعلمي القدير @ابو جودي كعادتك مبدع .

السلام عليكم و رحمة الله و بركاتة اخواني ارفق لكم برنامج تعليم الصلاة للاطفال على ان يربط البرنامج في صفحة الرئيسية A8 و ينقل المعلومات الى من a جميع الصفحات بحسب اختيار صفحة الرئيسية A8 و وضعها في صفحة الرئيسية E3 تعليم الاطفال الصلاة.xlsm

ما شاء الله تبارك الله اخي عمر ابدعت في هذه الفكرة لكن ظهرت عندي بعض رسائل الاخطاء مثل لم يستطع التعرف على tabnew وعدة تبويبات اخرى لكن الهدف الاساسي منه هو اخفاء زر الخيارات وقد تم الامر بنجاح لو تكرمت علينا بمصدر هذا الكود لعلنا نجد الاسماء الجديدة المستخدمة فيه وهذه لقطة شاشة للشريط الذي قمت بتصميمه

ممكن اعرف وش المانع لو استخدمنا هذي الخاصيه ؟؟

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

دا برنامج كنت عامله للمطلوب ان شاء الله يفيدك

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

وإضافة جميلة للمكتبة العامرة ☺️👌🏼

جرب، علما لم أعمل أي احترازات في حالة وجود أخطاء إدخال. Hijri2Gregorian_01.xlsm

كما أخبر أخونا الحبيب وانت خير من تعلم يا استاذى القدير ومعلمى الجليل @kkhalifa1960 اننا تعلمنا من اساتذتنا الكرام فى هذا الصرح كما عهدناهم تقديم العون والمساعدة واثراء المشاركات بمختلف الافكار والاجابات التى تعد زخرا لكل ماض و آت بكل حب وكرم وجود والاهم لا يريد ولا ينتظر أحد جزاءً أو شكورا .. هى لله املين من المولى عزوجل القبول ولم اعهدكم هكذا من قبل استاذى الجليل اسأل الله تعالى لى ولكم العفو و العافية و راحة البال و صلاح الحال و سعة الصدر و لباس العافية و حسن الخاتمة احبكم فى الله

يمكنك أيضا استخدام الكود Move Size لتضبيط موقع النموذج وأبعاده : https://learn.microsoft.com/en-us/office/vba/api/access.docmd.movesize?f1url=%3FappId%3DDev11IDEF1%26l%3Den-US%26k%3Dk(vbaac10.chm4158)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue

نيابة عن الأستاذ @بحار الاكسس وإن صح كلامي ( ولم أقم بتحميل المرفق ) ، فأعتقد أنك من خلال النموذج وأنت في وضع التصميم مثلاً قم بالتوجه إلى تبويب إنشاء واختر تصميم تقرير ، فيقوم آكسيس تلقائياً بإنشاء تقريره بناءً على النموذج المفتوح أو ( الذي وقفت عليه بنقرة واحدة بالماوس ) ؛ طبعاً الموضوع مرهون إن كان النموذج يعرض بيانات الشخص الذي ترغب بطباعة بياناته فقط لا أن يعرض بيانات وسجلات الجدول جميعها. وهنا سيكون للموضوع عدة حلول أخرى إما عن طريق استعلام ، أو ...... إلخ ( هذا والله أعلم )

دائماً مبدع أستاذنا الكبير ياسر , تبارك الله مجهود رائع جعله الله فى ميزان حسناتك وأكرمك الله وموضوع مهم للجميع جزاك الله خير الثواب

اتفضل البرنامج بعد التعديل badeelsheb.accdb

اتفضل استاذى بالضغط على ctrl+k سيحول اى مجموعة شيتات الى ملفات حتى لو كان 1000 شيك تحياتى mySheet.xlsm

وعليكم السلام من Format cells - Custom اكتب في حقل Type: yyyymmdd

أتصور أنه من الصعب أن تحد اجابة متفق عليها رأيي الشخصي اذا تتكلم عن تطبيق مؤسسي ضخم فأرشح الجافا ، و يرجع ذلك لمعايير الامان العالية. اما اذا تطبيق بسيط بعدد مستخدمين محدود فالأكسيس يأتي فى المقدمة للسهولة والملائمة من وجهة نظري ، مع امكانية الاستخدامنات المتقدمة بمجالات كبيرة باستخدام VBA اذا تطبيق لمؤسستك فهو الاكسيس ، و اذا ترغب فى تطبيق تجاري فربما نكون الجافا و الله أعلم

تفضل هذا الملف .على الرغم ان كان عليك من البداية رفع ملف بالمشاركة فلا تعنى أى مشاركة شيء بدون ملف يدعمها Colored.xlsb

وعليكم السلام-تفضل هذا الكود Sub ColorPaletteDialogBox() Dim lcolor As Long If Application.Dialogs(xlDialogEditColor).Show(10, 0, 125, 125) = True Then 'user pressed OK lcolor = ActiveWorkbook.Colors(10) ActiveCell.Interior.Color = lcolor Else 'user pressed Cancel End If End Sub

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك: Sub ColorCompanyDuplicates() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim i As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End Sub

بارك الله فيك وزادك الله من فضله -جمعة مباركة ان شاء الله

أحسنت استاذنا الكريم وبارك الله فيك جهود ممتازة جعله الله فى ميزان حسناتك

عمل ممتاز أستاذ حسونة بارك الله فيك وزادك الله من فضله

بارك الله فيك وزادك الله من فضله هدية قيمة أحسنتم

البقاء لله وان لله وان اليه راحعون اللهم اسكنه فسيج جناتك واغفر له وارحمه ةالهم اللهم اهله الصبر والسلوان على هذه المصيبة واجعله يا الله من أرباب جنات الفردوس الأعلى واحشره مع الصديقين والمرسلين والشهداء وحسن أولئك رفيقاً

وعليكم السلام-ياريت تقوم بتغيير عنوان المشاركة ليصبح ( معادلة IF متعددة الشروط) وهذه المعادلة تفى بالغرض وشكراً =IF(AND($C4<>"غ",$B4="ذكر"),"ناجح",IF(AND($C4<>"غ",$B4="أنثي"),"ناجحة",IF(AND($C4="غ",$B4="ذكر"),"ناجح بحكم القانون",IF(AND($C4="غ",$B4="أنثي"),"ناجحة بحكم القانون","")))) معادلة IF.xlsx

وعليكم السلام-تفضل هذه المعادلة تخص اللون الأخضر =COUNTIFS($G$5:$G$700,">=9",$G$5:$G$700,"<=10") أما اللون الأحمر فيكفيك هذه المعادلة ...وشكراً =COUNTIF($G$5:$G$700,"<=4") فرق بين تاريخين.xlsx

تفضل هذا بمعادلة مصفوفة (Ctrl+Shift+Enter) Report Between Two Dates.xlsb

وعليكم السلام لا يمكن فتح أى ملف اكسيل يحتوى على أكواد VBA على الموبيل وشكراً !

وعليكم السلام .. لابد ان يكون هناك ملف اكسيل بأى مشاركة لتدعيمها وتوضيح المطلوب بكل دقة وذلك تجنباً لإهدار الوقت !! ولكن عليك بوضع هذا الكود بحدث ThisworkBook حتى يتم تنفيذ طلبك Private Sub Workbook_Open() Worksheets("Main").Activate Range("D5").Select End Sub وهناك كود أخر بالملف المرفوع لك للإنتقال الى خلية معينة من الصفحة الأخرى وسيكون ذلك بمديول عادى Example.xlsm

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

تم ضبط الأبعاد بدقة فعليك بعدم العبث بها 1عتماد مستندات نهائى1.xls

بارك الله فيك ... وتقبل الله منا ومنكم سائر الأعمال

بارك الله فيك استاذنا الكريم وجزاك الله خير الثواب

وعليكم السلام-تم ضبط وعمل المطلوب بالكود وتجربته بالفعل على الطابعة ويعمل بكل كفاءة ملحوظة : عليك بعدم العبث بأبعاد الصفحات او محاولة تغييرها وهذا هو الكود المستخدم فى ذلك Private Sub Do_It() Application.ScreenUpdating = False With Sheets("قطاعات") a_max = .Cells(.Rows.Count, "A").End(xlUp).Row b_max = a_max prows = 45 a = 5 Do a = a + prows Loop Until a + 45 >= a_max .Rows(a_max + 1 & ":" & a_max + 3).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sheets("Sheet1").Range("A1:F3").Copy Destination:=.Cells(a_max + 1, "A") b_max = b_max + 3 For aa = a To 5 + prows Step -prows .Rows(aa & ":" & aa + 2).Insert shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Sheets("Sheet1").Range("A1:F3").Copy Destination:=.Cells(aa, "A") b_max = b_max + 3 Next aa .PageSetup.PrintArea = "A1:F" & b_max .PrintOut For a = 5 + prows To a_max Step prows .Rows(a & ":" & a + 2).Delete shift:=xlUp Next a .Rows(a_max + 1 & ":" & a_max + 3).Delete shift:=xlUp .PageSetup.PrintArea = "A1:F" & a_max End With Application.ScreenUpdating = True End Sub 1اعتماد مستندات.xls

أحسنت استاذ محمد عمل هائل بارك الله فيك وزادك الله من فضله

وعليكم السلام-ضع هذا الكود فى حدث Thisworkbook Private Sub Workbook_Open() UserForm1.Show End Sub Backup of work2.xlsm

أحسنت استاذ عبد اللطيف بارك الله فيك وزادك الله من فضله

عمل ممتاز استاذ عبدالله بارك الله فيك وزادك الله من فضله

وعليكم السلام -تفضل ملف قيم لما تريد List All files from Folder and Sub-folders in Excel Workbook File_Manager.xlsm وهذا ملف اخر Open Excel files in a folder [VBA] List-all-files-in-a-folder.xlsm وهذا الرابط من داخل المنتدى أيضاً سيفيدك للأستاذ محمد صالح شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba

أحسنت اخى الكريم عمل رائع بارك الله فيك وزادك الله من فضله