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

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخى باسسورد الدخول 123 نظام الحسامي للمخازن-123.xlsb

لم تدكر اخي ما هو النطاق المطلوب تفضل جرب هل هدا ما تقصده Sub CopySheet() Dim filePath$, folderName$, Fname$ Dim rCopy As Range, rng As Range Dim lRow As Long, i As Integer Dim wbSource As Workbook Set wbSource = ThisWorkbook Set WS = wbSource.Worksheets("Sheet1") lRow = WS.Range("B" & WS.Rows.Count).End(xlUp).Row Set rCopy = WS.Range("A7:K" & lRow).SpecialCells(xlCellTypeVisible) folderName = "ملفات Excel" Fname = "تقرير النشاط" filePath = ThisWorkbook.path & "\" & folderName On Error Resume Next 'OR 'filePath = "D:" & "\" & folderName If WS.Range("L9:L" & lRow).SpecialCells(xlCellTypeVisible).Count > 1 Then With Application .ScreenUpdating = False .DisplayAlerts = False .CopyObjectsWithCells = False Set newWb = Workbooks.Add: Set SH = newWb.Sheets(1) rCopy.Copy Destination:=SH.Range("A3") LastR = SH.Range("A" & SH.Rows.Count).End(xlUp).Row SH.Range("A7:A" & LastR).RowHeight = 28 For i = 1 To 11 Columns(i).ColumnWidth = WS.Columns(i).ColumnWidth Next i SH.[A5] = 1: SH.Range("A5:A" & SH.Cells(Rows.Count, 2).End(3).Row).DataSeries , xlLinear 'Columns(1).Delete If Dir(filePath, vbDirectory) = "" Then MkDir filePath newWb.SaveAs fileName:=filePath & "\" & Fname & ".xlsx", FileFormat:=51 newWb.Close .CopyObjectsWithCells = True .DisplayAlerts = True .ScreenUpdating = True End With sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & WS.[D4] & " " & "إلى تاريخ:" & " " & WS.[F4] Else MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء" End If End Sub فلترة وحفظ.xlsm

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

وعليكم السلام ورحمة الله وبركاته اخي @salah.sarea . ضع هذا الكود في حدث عند النقر لزر الإصلاح ، مع تحديد مسار قاعدة البيانات B_Be حسب ما تريد . Private Sub btnRepair_Click() Dim strConnect As String Dim strPassword As String strPassword = "123" strConnect = "MS Access;PWD=" & strPassword & ";DATABASE=path_to_b_be.accdb" Application.CompactRepair SourceFile:="path_to_b_be.accdb", DestinationFile:="path_to_b_be.accdb", _ Password:=strPassword MsgBox "تم إصلاح قاعدة البيانات بنجاح!", vbInformation End Sub طبعا على افتراض أن اسم الزر btnRepair.

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

بكل سرور اخي @Alaa Ammar New يسعدنا اننا استطعنا مساعدتك

اقرأ هذا الموضوع وسوف يساعدك في ذلك ...................................

الحمد لله الذي وفقك لما تريد اخى @mahmoud nasr alhasany ولا داعى ابدا للاعتذار فكلنا هنا من اجل هدف واحد وهو مساعده اخواننا

على قددر علمي اقدم لكم هذه الهدية للتحكم فى خيارات العرض والتشغيل كما هو موضح فى الصورة المرفقة اضفت نموذج ارضية وشريط ادوات عائم يمكنتك تطويره يلاحظ ان خاصية autocompact معطلة فى كلا الحالتين يمكنك تفعيلها تقبلوها منى خالصة لوجه الله تعالى وارجوا امدادى بخصائص اخرى حبث انى حديث عهد باكسس ولا تنسوا التقييم والرأي ولفت نظرى لاى خطأ كلمة السر 123 يمكنك تعديلها dboptions.rar

الاخ المحترم @Foksh قمت بتعديل نهائي لما يلزم مع الاستفادة من خيار اعادة التشغيل المقدم من طرفكم وضبط كل شئ دون التأثير على الخيارات او اجراء تغييرات غير محسوبة كما تم اضافة زر اعادة تشغيل كخيار للشريط العائم ونموذج الارضية والنموذج الرئيسي ارجو ان ينال الامر اعجابك وكنت اتمنى استبدال الملف الرئيسي باول البوست dboptions.rar

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

ادا كنت قد فهمت طلبك بشكل صحيح يمكنك الحصول على دالك بتفعيل هدا السطر حيث يتم فلترة البيانات بشرط عمود المفتاح ما بين التواريخ الموجودة في الخلايا D4 و F4 '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) اما بالنسبة ل كود عمل نسخة احتياطية كل عشر دقائق ضع الكود التالي في module Sub SaveBackup() Dim filePath$,folderName$,copyName$ Dim ThisBook As Workbook : Set ThisBook = ThisWorkbook 'مسارالحفظ ' filePath = "D:": 'اسم مجلد الحفظ folderName = "BACKUPS" With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next copyName = filePath & "\" & folderName & " " & _ Format(Now, "dd-mmmm-yyyy") 'انشاء مجلد الحفظ في حالة عدم العثور عليه If Dir(copyName, vbDirectory) = "" Then MkDir copyName ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _ Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm" ' قم بتعديل وقت الحفظ بما يناسبك Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup" 'حفظ المصنف الرئيسي ' ActiveWorkbook.Save .DisplayAlerts = True .ScreenUpdating = True End With End Sub وفي حدث Private Sub Workbook_Open Private Sub Workbook_Open() Call SaveBackup End Sub تفضل جرب المرفق التالي بالتوفيق فلترة وحفظ.xlsm

وكملاحظة لم اقم بتعديلها وتركتها لك لاكتشافها 😉 1. إيقاف قوائم اكسيس ، وإيقاف القوائم المختصرة تعمل بالعكس 2. ستجد بعض رسائل الخطأ قد ظهرت وتحتاج الى تلافيها حسب الكود الخاص بك ، فلم أطلع كثيراً على تسلسل الأحداث في الأكواد بتمعن 😊

اعتذر عن الخطأ فهو خاص بكود اخر غير مضمن وسارفع نسخة جديدة قريبا بدون الخطأ وتتضمن اقتراحكم باعادة التشغيل الاخ @Foksh مرفق نسخة معدلة لكن ارجو ضبط موضوع اعادة التشغيلواعادة الارسال dboptions.rar

لا يوجد قائمه منسدله انما ليست بوكس يتم التحكم بها من الكود Listbox1.left = 8000 Listbox1.top = 5 ممكن تعدلهم كيفما شئت

السلام عليكم كنت ابحث عن برنامج على جهازي الكمبيوتر بالصدفة وجدت هذا الملف الرائع احببت المشاركة معكم للفائدة اكواد كسس مهمة.rar