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

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

السلام عليكم ورحمة الله وبركاته هذه محاولة في الملف المرفق إن كنت قد وُفقت في فهم المطلوب... جرد المخزن_1.xlsx

طيب ، سأشرح لك الدالة `GenerateSequence` هذه الدالة تقوم بإنشاء تسلسل رقمي للاسماء المتشابهة في استعلام : 1. `Function GenerateSequence( FullName As String) As Integer`: هذا تعريف الدالة `GenerateSequence` التي تأخذ مُدخل واحد يُسمى ` FullName` من نوع `String` وتُرجع قيمة من نوع `Integer`. 2. `Static dict As Object`: هنا نُعرف متغير `dict` ككائن `Object`. الكلمة `Static` تعني أن الكائن `dict` سيحتفظ بقيمته حتى بعد انتهاء تنفيذ الدالة، وهذا مهم لأننا نريد أن يحتفظ القاموس بالاسماءوالأرقام المتسلسلة التي تم إضافتها سابقًا. 3. `If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")`: هذا الشرط يتحقق إذا كان الكائن `dict` لم يتم إنشاؤه بعد، وفي هذه الحالة يتم إنشاء كائن جديد من نوع "Dictionary" (قاموس). 4. `If Not dict.exists( FullName) Then`: هذا الشرط يتحقق إذا كان الاسم` FullName` غير موجود في القاموس `dict`. 5. `dict.Add FullName, dict.Count + 1`: إذا كان الاسم` FullName` غير موجود، يتم إضافته إلى القاموس مع قيمة تسلسل رقمي جديدة تُحسب بإضافة واحد إلى عدد الاسماء الموجودة في القاموس. 6. `GenerateSequence = dict( FullName)`: في النهاية، تُرجع الدالة القيمة المتسلسلة للاسم` FullName` الموجود في القاموس. باستخدام هذه الدالة في استعلام، يمكنك إنشاء حقل محسوب يعرض رقمًا متسلسلًا لكل اسم متشابه بناءً على ترتيب ظهوره في الاستعلام. هذا مفيد لتتبع الاسماء وترتيبها بشكل فريد داخل الاستعلام.

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

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخى باسسورد الدخول 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.

اسف اخي لم انتبه فعلا على العموم حل الاستاد حسونة سوف يلبي المطلوب بالتوفيق.

تفضل لان الخليه f3 بها تاريخ ظهر لك هذا الخطأ sNewFilePath = ThisWorkbook.Path & "\" & Replace(Range("F3").text, "/", "-") & ".pdf"

الله ينفع بك أستاذنا محمد هشام تم تعريف المتغيرات حتى لا تحصل مشاكل مستقبلية تم إضافة جزئية الحصول على مسار سطح المكتب للمستخدم الحالي بحيث ما تتعب مستقبلا في نقل الملف لكمبيوتر آخر Sub SaveBackup() Dim filePath As String Dim FolderName As String Dim copyName As String Dim ThisBook As Workbook Set ThisBook = ThisWorkbook ' هنا سيتم الحصول على مسار الجهاز filePath = Environ("UserProfile") & "\Desktop" FolderName = "BACKUPS" With Application .ScreenUpdating = False .DisplayAlerts = False 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" .DisplayAlerts = True .ScreenUpdating = True End With End Sub

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

جرب هدا Private Sub TextBox1_Change() Set WS = Sheets("Sheet1") On Error Resume Next If WS.TextBox1.Text = Empty Then WS.[A8:L8].AutoFilter lr = WS.Cells(WS.Rows.Count, "L").End(xlUp).Row Clé = "*" & Replace(WS.TextBox1.Text, " ", "*") & "*" If WS.TextBox1.Text <> "" Then Set rng = WS.Range("A8:L" & lr) '****المفتاح***** rng.AutoFilter field:=12, Criteria1:=Clé '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) Else WS.[A8:L8].AutoFilter End If End Sub Sub test() Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Set a = desWS.Range("A8", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) ' For r = 1 To 11 لغاية عمود الملاحظات For r = 1 To 12 'مفتاح ' لغاية عمود Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A3:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True End Sub فلترة وحفظ PDF +EXCEL V2.xlsm

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كنت قد بحثت في المنتدى 🔍 (هنا) عن برامج لعرض مواقيت الصلاة ، وقد وجدت الكثير من المواضيع الجميلة والأفكار النيرة في المنتدى لأساتذة وأخوة بذلوا جهداً لا يوصف في مشاركاتهم بهذا الموضوع ، وإلى حد ما أكثرهم قرباً لضبط الأوقات كانت هذه المشاركة . اليوم الفكرة مختلفة قليلاً في هذا المشروع المتواضع والذي لا يحتوي تعقيدات يصعب قراءتها أو التعامل معها في الأكواد . حيث اعتمدت وتوجهت إلى البساطة من حيث عند النقل والدمج ( إلى / في ) أي مشروع . الآن شرح بسيط لبعض تفاصيل المشروع التي سيتم الإعتماد عليها :- سي سيتم الإعتماد على خطوط الطول والعرض بعد إجراء بعض التعديلات على طريقة احتساب الأوقات . وقد تمت المقارنة مع موقع ( مواقيت الصلاة ) للوصول إلى أقل فارق - إن وُجِد - في المواقيت . سيتم الإعتماد على تقويم أم القرى في أحدى مشاركات أستاذنا @ابوخليل . سيتم اعتماد إظهار الوقت المتبقي لكل موعد صلاة في الشاشة الرئيسية أو المصغرة ( ستضاف لاحقاً ) . سيتم منح الحرية للمستخدم بنوع التذكير لوقت الصلاة ( إشعار برسالة تنبيه داخل البرنامج ، إشعار فوق شريط Taskbar ) . سيتم أيضاً منح الحرية للمستخدم باختيار صوت التنبيه ( أذان كامل ، تكبير ، .... إلخ ) . المزيد من الأمور ستأتي لاحقاً تباعاً في تطويرات وتحديثات جديدة إن شاء الله . صورة لواجهة البرنامج حالياً ، والذي أسميته في الوقت الحالي " صلوات " 🤗 ، ما لم يتم اختيار اسم آخر

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

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل نموذج ادخال بيانات الحجاج داخل الشيت.xlsm

معك حق تم تعديل الكود تفضل جرب الملف واعلمنى بالنتيجة 1.xlsm

cleantabeles.rar تفضل اخي كان هناك خطأين اعتذر عنهم لاني جمعت لك الكود بسرعة وكنت اختبر من زر وليس موديول فقط تستبدل me باسم النموذج هكذا forms!cleaner كما ان هناك متغير معلن اكثر من مرة اوقفته الان الكود يعمل لكننا استبدلنا احد الحروف الخمسة بكلمة عبد لامكانك اضافة حلقة جديدة للحرف او اى شئ اخر cleantabeles.rar

تحياتي... ألق نظرة على الملف المرفق لعل فيه ما تريد... حساب النقاط.xlsx

بارك الله فيك وزادك الله من فضله اللهم اغفر لوالدك وارحمه، وعافه واعف عنه، وأكرم نزله، ووسع مدخله، واغسله بالماء والثلج والبرد، ونقه من الخطايا كما ينقى الثوب الأبيض من الدنس. - اللهم أبدله دارا خيرا من داره، وأهلا خيرا من أهله، وزوجا خيرا من زوجه، وأدخله الجنة، وأعذه من عذاب القبر، ومن عذاب النار

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

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

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

IFERROR(LOOKUP(A1,{600001;700001;800001;900001},{525;2775;5025;8025}) بسيطة وسهلة هذا الجزء يعنى ان الشرائح التى تبدأ بـــ600001 يكون الوعاء الضريبى هو المقابل لها بالقوسين الأخرين وهو 525 أما الشريحة الثانية 700001 فالوعاء الضريبى لها هو 2775 ...وهكذا الى اخر الشرائح وشكراً

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

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

شكرا استاذي الفاضل أنا بدلت الكود القديم بالجديد وعند التطبيق تمام في حذف المسافات ولكن عند تطبيق تبديل الخمسة اشياء يعطيني خطأ في الكود مرفق لحضرتك الملف بعد تبديل الكودcleantabeles.accdb

😉 اقصد هذا السطر يا صديقي hMenu = GetSystemMenu(hwnd, 1&)

عمل جيد أخي @طير البحر ودعماً لمحاولتك ، هذا الجزء الخاص بزر RestoreDown Sub DisableRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M And Not WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub Sub RestoreRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M Or WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub بعد إذنك لاحظت وجود خطأ في الجزء المسؤول عن أعادة تفعيل زر اغلاق الآكسيس :- أرجو التعديل من هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 0&) If hMenu Then ' DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND 'Disable the Close button ááÇáÛÇÁ DrawMenuBar (hwnd) 'Repaint the MenuBar ááÊÔÛíá End If End Sub إلى هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 1&) If hMenu Then DrawMenuBar (hwnd) End If End Sub

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

Do it yourself Press Alt + F11 >> Insert Module >> Paste the code

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

Try this code Sub Test() Dim ws As Worksheet, fso As Object, sPath As String, lr As Long, iRow As Long Set ws = ActiveSheet Set fso = CreateObject("Scripting.FileSystemObject") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ws.Columns(1).Interior.Color = xlNone For iRow = 2 To lr sPath = ThisWorkbook.Path & "\" & ws.Cells(iRow, 1).Value If fso.FolderExists(sPath) Then ws.Cells(iRow, 1).Interior.Color = vbGreen End If Next iRow End Sub

زادك الله من علمه ونفع بك الناس الصراحة استفدت منك وتعلمت بارك الله فيك وجزاك الله خيرا في تعليم ومساعدة الناس

الكود السابق اخي وباختصار يقوم بانشاء جدول مؤقت باسم year_table في كل مرة يجلب البيانات من استعلام معين حسب جدول السنة ( الاولى - الثانية - الثالثة ) عن طريق select case ثم يقوم بتصدير البيانات لملف الاكسل ... ثم حذف الجدول المؤقت هنا مثال ممتاز لاخونا الاستاذ @ابوخليل مثلا عند no ابحث في مثال اخونا تجدها من ضمن الكلمات المحجوزة الحقول المحسوبة اعني بها في الجدول .... حاول تعملها في الاستعلام او التقرير او النماذج .... والله اعلم

اخي الكريم من وجهة نظري الشخصية ::: لديك بعض الأخطاء منها ::::: * استخدام الكلمات او العبارات المحجوزة للأكسس * تكرار بعض مسميات الحقول في الاستعلامات * الحقول المحسوبة * ايضا ادخال المواد التدريسية لماذا لم تتم بشكل سجلات بدلا من ادخالها افقيا على كل حال ( لو كنت مصر على طريقتك تفضل بعض الحل للمشكلة ) اعمل زر وضع فيه هذه الشيفره Dim sXlsFile As String sXlsFile = CurrentProject.Path & "\ww1.xlsx" DoCmd.SetWarnings False If Not IsNull(Forms!w_moka_mid9!MM) Then Select Case Forms!w_moka_mid9!MM Case Is = "الاولى" DoCmd.RunSQL " SELECT [year-table1].[full-name], [year-table1].[natio-no], [year-table1].exper, [year-table1].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table1] " & _ " WHERE ((Not ([year-table1].EXPR5) Is Null));" Case Is = "الثانية" DoCmd.RunSQL " SELECT [year-table2].[full-name], [year-table2].[natio-no], [year-table2].exper, [year-table2].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table2] " & _ " WHERE ((Not ([year-table2].EXPR5) Is Null));" Case Is = "الثالثة" DoCmd.RunSQL " SELECT [year-table3].[full-name], [year-table3].[natio-no], [year-table3].exper, [year-table3].cerf, [EXPR2] & "", "" & [EXPR3] & "", "" & [EXPR4] AS EXPR6 INTO year_table " & _ " FROM [year-table3] " & _ " WHERE ((Not ([year-table3].EXPR5) Is Null));" End Select Call Export_Excel_officena_by_aba_judy(sXlsFile, "SELECT * FROM year_table", 6) DoCmd.DeleteObject acTable, "year_table" Else MsgBox "اختر جداول السنة المطلوب عرض تقريرها", vbCritical, "انتبــــــه" End If DoCmd.SetWarnings True

بارك الله فيك وزادك الله من فضله

اخي عاصم ممكن التواصل مع حضرتك لو سمحت

عدل DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf" الى DestPath = "\\10.20.30.3\homedir\a.ghanem\كشف العمليات اليومية\" & Sh.Range("e11") & ".pdf"

السلام عليكم ورحمة الله تم عمل المطلوب مع بعض الإضافات المستحسنة (تحضير قائمة منسدلة للصفوف بالتسمية Liste من خلال معادلات في العمودين Z و AA من شيت ... ) new2.xlsx

استكمالاً لما سبق 👆 :- بطريقة بسيطة سيتم الاعتماد على حساب الجيب العكسي للزوايا باستخدام دالة الرمز الجيبي العكسي (Arcsine)، والتي يُرمز لها بـ ASin . تُستخدم الدالة ASin في الرياضيات لحساب الزاوية التي تمثلها الجيب العكسي لنسبة محددة من الجانب المقابل لزاوية مثلث، عندما يُعرف طول الضلع المقابل لهذه الزاوية . ويتمثل ذلك في المعادلة الرياضية . صورة تعبيرية وبناءً على هذه المعادلة سيتم احتساب أوقات الصلاة باستخدام معادلات فلكية و جيوغرافية ، ومن ثم سنعيد القيمة الراجعة بتنسيق معين بشكل وقت . حسب المديول التالي ، والذي يعتبر عامود المشروع وقوامه وأساسه :- Option Compare Database Const PI As Double = 3.14159265358979 Function ASin(Value As Double) As Double If Abs(Value) <> 1 Then ASin = Atn(Value / Sqr(1 - Value * Value)) Else ASin = 1.5707963267949 * Sgn(Value) End If End Function Public Function ACos(ByVal nValue As Double, Optional fRadians As Boolean = True) As Double ACos = -Atn(nValue / Sqr(1 - nValue * nValue)) + PI / 2 If fRadians = False Then ACos = ACos * (PI / 180) End Function Function gettimes(lag As Double, lat As Double, tzon As Double, stime As String, method As Integer, Optional dylt As Integer = 0, Optional strdate As Date) As Date ' تعريف المتغيرات المستخدمة Dim D, L, m, lambda, alpha, noon, alt, UTNoon, localNoon, st, Dec, ar, obl As Double ' حساب تاريخ اليوم D = (367 * Year(strdate)) - Int(((Year(strdate) + Int((Month(strdate) + 9) / 12)) * 7) / 4) + Int(275 * Month(strdate) / 9) + Day(strdate) - 730531.5 ' حساب زاوية الشمس والشروق والغروب L = 280.461 + 0.9856474 * D L = L - (360 * Int(L / 360)) m = 357.528 + 0.9856003 * D m = m - (360 * Int(m / 360)) lambda = L + 1.915 * Sin(m * PI / 180) + 0.02 * Sin(2 * m * PI / 180) obl = 23.439 - 0.0000004 * D ' حساب موضع الشمس وزاوية الشروق والغروب alpha = Atn(Cos(obl * PI / 180) * Tan(lambda * PI / 180)) * 180 / PI alpha = alpha - (360 * Int(alpha / 360)) alpha = alpha + 90 * (Fix(lambda / 90) - Fix(alpha / 90)) st = 100.46 + 0.985647352 * D st = st - (360 * Int(st / 360)) Dec = ASin(Sin(obl * PI / 180) * Sin(lambda * PI / 180)) * 180 / PI noon = alpha - st noon = noon - (360 * Int(noon / 360)) UTNoon = noon - lag localNoon = (UTNoon / 15) + tzon + dylt ' حساب أوقات الصلاة Select Case stime Case Is = "Fajr" ' حساب وقت الفجر alt = DLookup("FajrDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI fajr = localNoon - ar / 15 gettimes = Format(fajr / 24, "hh:nn:ss") Case Is = "Shrok" ' حساب وقت الشروق alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI shrouk = localNoon - ar / 15 gettimes = Format(shrouk / 24, "hh:nn:ss") Case Is = "Zohr" ' حساب وقت الظهر gettimes = Format(localNoon / 24, "hh:nn:ss") Case Is = "Asr1" ' حساب وقت العصر (الطريقة الأولى) alt = 90 - Atn(1 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Asr2" ' حساب وقت العصر (الطريقة الثانية) alt = 90 - Atn(2 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Maghrib" ' حساب وقت المغرب alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 gettimes = Format(maghrib / 24, "hh:nn:ss") Case Is = "Eshaa" ' حساب وقت العشاء If method = 4 Then alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 If Month(CStr(Date)) = 9 Then gettimes = Format((maghrib + 2) / 24, "hh:nn:ss") Else gettimes = Format((maghrib + 1.5) / 24, "hh:nn:ss") End If Else alt = DLookup("IshaDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI eshaa = localNoon + ar / 15 gettimes = Format(eshaa / 24, "hh:nn:ss") End If End Select End Function يتبع ... 👈

مرحبا بك استاذ @jo_2010 بالنسبة للمطلب الثاني ليست لدي فكرة عنه LAB_GOOD.rar

فكره حلوه ،، شكرا على الهديه الجميله

تسلم على الهدية القيمة

لا اعتقد ذلك .

السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد @عبدالله بشير عبدالله اليك حل اخر ربما يناسبك هدا الكود لفلترة البيانات بين التواريخ ونسخها لورقة مخفية على نفس المصنف باسم printing Sub FilterByDate() Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing Dim MinDate As Date, MaxDate As Date, lr As Long Dim a As Range, r As Long MinDate = desWS.[d2]: MaxDate = desWS.[f2] Application.ScreenUpdating = False If MinDate > MaxDate Then: Exit Sub If Len(desWS.[f2]) > 0 And IsDate(desWS.[d2]) Then If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A7:K7") .AutoFilter 3, ">=" & CLng(MinDate), 1, "<=" & CLng(MaxDate) lr = WS.Columns("A:K").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A" & lr & ":k" & lr).SpecialCells(xlCellTypeVisible) If WorksheetFunction.Subtotal(3, WS.Columns(3)) > 1 Then desWS.Range("A5:K" & Rows.Count).Clear With rng Cpt = Split("A,B,C,D,E,F,G,H,I,J,k", ",") Col = Split("A,B,C,D,E,F,G,H,I,J,k", ",") For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "8:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "5") Next i End With lige = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Cpt1 = "=IF(c5="""","""",IF(c5=""Name"",""Count"",N(b4)+1))" Cpt2 = "=IF(ISBLANK(b5),"""",SUBTOTAL(3,B$5:B5))" With desWS .Range("B5:B" & lige).Formula = Cpt1: .Range("A5:A" & lige).Formula = Cpt2 .Range("A5:B" & lige).Value = .Range("A5:B" & lige).Value End With End If .AutoFilter End With f.Range("A2:K" & f.Rows.Count).Clear Set a = desWS.Range("A4", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) For r = 1 To 11 Set a = Union(a, Intersect(a.EntireRow, Columns(r))) Next r a.Copy Destination:=f.Range("a2") End If Application.ScreenUpdating = True End Sub لحفظ الملف بصيغة PDF Sub Save_folder_PDF() Dim sFile As String, sPath As String, fPath As String Dim sMsg As String Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim f As Worksheet: Set f = printing sFile = "تقرير النشاط" folderName = "ملفات PDF" Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, f.Name) If Msg <> vbYes Then Exit Sub f.Visible = xlSheetVisible With ActiveWorkbook sPath = .path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath f.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.Visible = xlSheetVeryHidden End With sMsg = "PDF" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] Application.ScreenUpdating = True End Sub لحفظ التقرير في ملف مستقل Sub Save_folder_Excel() Dim WS As Worksheet: Set WS = printing Dim desWS As Worksheet: Set desWS = Sheets("الانشطة") Dim path As String, folderName As String, sMsg As String Dim newWb As Workbook, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Visible = xlSheetVisible folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Set newWb = ActiveWorkbook newWb.SaveAs FileName:=path & Fname & ".xlsx", FileFormat:=51 newWb.Close WS.Visible = xlSheetVeryHidden .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & desWS.[d2] & " " & "إلى تاريخ:" & " " & desWS.[f2] End Sub فلترة وحفظ PDF +EXCEL.xlsm

بارك الله فيك وزادك الله من فضله

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

وعليكم السلام-تفضل لا يمكن ذلك الى بكود بوضعه فى حدث ThisWorkBook Private Sub Workbook_Open() Sheet2.Select End Sub الشهادات المدرسية للقدامى للسنوات السابقة.xlsm

تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ) Option Explicit Option Base 1 Sub Salim_Extract() Dim Src_Sh As Worksheet Dim Trg_Sh As Worksheet Dim xx, lr, m, My_Row As Integer Dim ArrJ(), ArrG() Dim t As Long Application.ScreenUpdating = False My_Row = 4 Set Trg_Sh = Sheets("الديون") Trg_Sh.Range("e4").Resize(10000, 3).Clear For m = 3 To Sheets.Count - 2 t = 1 Set Src_Sh = Sheets(m) With Src_Sh .Select On Error GoTo 1 On Error Resume Next lr = .Cells(Rows.Count, "j").End(3).Row For xx = 4 To lr If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then ReDim Preserve ArrJ(t) ReDim Preserve ArrG(t) ArrJ(t) = .Cells(xx, "j").Value ArrG(t) = .Cells(xx, "G").Value: t = t + 1 End If Next End With Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG) Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy" My_Row = My_Row + t Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6 1: Erase ArrJ: Erase ArrG Next Application.ScreenUpdating = True Trg_Sh.Activate: Range("e3").Select End Sub الملف المرفق اصنافform salim 1.rar