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

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

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

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

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

تفضل لان الخليه 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

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

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

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

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

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

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

السلام عليكم ورحمة الله تم عمل المطلوب في الملف المرفق... كان يكفي أن تُنسخ المعادلات نفسها مع تغيير الشروط حسب ما وضعت في طلبك... new2.xlsx

وعليكم السلام- تفضل بما انك لم تقم برفع ملف توضيحى للمطلوب يكل دقة Book.xlsx

السلام عليكم ورحمة الله وبركاته وبها نبدأ عدل الفاصلة , الى الفاصله المنقوطه ; لتصبح معادله ابو احمد هكذا =IF(F8*0.0199<1.99;1.99;IF(F8*0.0199>2.99;2.99;F8*0.0199))

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

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

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

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

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

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

مرفق برنامج للمقابلات ( meeting ) مجزء الي : ملف البيانات به الجداول ملف الارسال وسيتم من خلاله ارسال البيانات ملف الاستقبال هو ملف الالحاق الذي سيستقبل فية البيانات وهو الملف الذي سيتم فيه المساعدة عند استقبال سجل تم الحاقة بالملف وتم الموافقة علية من خلال الرئيس يتم التأشير عليه وتلوينة بالون الاخضر واذا تم الرفض بالون الاحمر والانتظار بالون الاصفر meeting.rar

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

فى ظل امكاناتي المتواضعه وللحاجه وبعد مراجعة العديد من الحلول المتوفره على الويب التى لم اجد بها ضالتي اقدم لكم مربع التلوين هذا colorpicker حيث يقوم بتلوين خلفية النموذج بشرط تسميتها detail بالانجليزيه ورأس النموذج بشرط تسميته header وتذييل النموذج بشرط تسميته footer وكذلك مربعات التنسيق والتجميل rectangle بشرط ان يتم تسميتها box1 , box2 وهكذا وضعت وظائف التلوين فى حدث عند النقر المزدوج فى كل منها طبعا يمكن استخدام اسماء عناصر عربيه لكنها ستحتاج تعديل فى الجدول والكود ولا افضل ذلك المربعات الونيه يمكن تلوين حتى box9 اى تسع مربعات النموذج يحتوي اكثر من 400 لون معد سلفا منها 160 لون عشوائي تتغير بضغطة زر الى اخرى كل لون تختاره يمكنك التعديل عليه بتغيير قيم الالوان الاحمر والاخضر والازرق يوجد جزء خاص لضبط الخطوة فى + او - بقيم من 1 حتى 25 كما يوجد جزء خاص بتحديد سلوك تلوين الفورم فى المره القادمه التى سيفتح فيها وامامك 3 خيارات اما استخدام خياراتك الاخيرة للالوان واما استخدام الوان الجدول الافتراضيه وهى الوان رماديه يمكن تغييرها من الجدول فقط واما استعادة الوان الفورم عندما تم تصميمه ويتم التحكم فى كل جزء على حده اعلم انه بدائي لكنه يؤدي الغرض بفاعليه ونرحب بالافكار الجديده الكود متاح للجميع استخدامه شخصيا او تجاريا بشرط عدم ازاله شعار مؤسسة وعد الخيريه او كود الصوره اتمنى تزويدي بتعليقاتكم البرمجيه لتحسي الكود وتطويره لتعيين الصور كخلفيات يمكن التحميل من هنا mycolorpiker.zip

شكرا لكم احبتي في الوقت الحاضر انا على جناح سفر ان شاء الله اذا عدنا وكتب الله لنا بقية من العمر .. ابشروا

عمل رائع أتمنى لك التوفيق

بارك الله فيك وجزاك خيرا ورحم الله والدك

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

تم التعديل على الفورم1 ...... جرب واعلمنا Desktop.rar

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

اذا ما هو الداعي لتصديره للاكسل ؟؟؟ حتى نستطيع المساعدة

جرب هذا المرفق أخي @imad2024 Copy Files.accdb تم انشاء مربعي النص ( Text1 , Text2 ) لتحديد المسارات ( المصدر والهدف ) وتم انشاء الزرين ( Btn1 , Btn2 ) بجانب كل مربع نص لتحديد مسار المجلدات . وتم انشاء زر لتنفيذ عملية النسخ من - إلى وتم انشاء دالة مستقلة للنسخ CopyFolder . Private Sub Btn_Copy_Click() If Text1.Value <> "" And Text2.Value <> "" Then Dim sourcePath As String Dim destPath As String sourcePath = Text1.Value destPath = Text2.Value If Dir(sourcePath, vbDirectory) <> "" Then If Dir(destPath, vbDirectory) <> "" Then CopyFolder sourcePath, destPath MsgBox "تم نقل الملفات بنجاح", vbInformation Else MsgBox "المجلد الهدف غير موجود", vbExclamation End If Else MsgBox "المجلد المصدر غير موجود", vbExclamation End If Else MsgBox "يرجى تحديد مسار لكل من المجلد المصدر والمجلد الهدف", vbExclamation End If End Sub Private Sub Btn1_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text1.Value = selectedFolder End If End Sub Private Sub Btn2_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text2.Value = selectedFolder End If End Sub Private Sub CopyFolder(ByVal sourcePath As String, ByVal destPath As String) Dim fso As FileSystemObject Set fso = New FileSystemObject Dim sourceFolder As Folder Set sourceFolder = fso.GetFolder(sourcePath) Dim destFolder As Folder Set destFolder = fso.GetFolder(destPath) fso.CopyFolder sourceFolder.Path, destFolder.Path End Sub

يعني انت لا تريد حفظ ملف الاكسل ... تريد فقط العرض

أخواني واساتذتي ، ما زال العمل على المشروع قيد التطوير 🤗

شكر وتقدير واحترام من اخيك

طلع عندي هيك ما في اوقات للصلوات ؟؟

اذا كنت مصر على طريقتك تفضل التعديل .... Function Export_Excel_officena_by_aba_judy(sXlsFile As String, sQuery As String, WrSht As Integer) Dim oExcel As Object Dim oExcelWrkBk As Object Dim oExcelWrSht As Object Dim bExcelOpened As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset Dim iCols As Integer Const xlCenter = -4108 On Error Resume Next Set oExcel = GetObject(, "Excel.Application") If Err.Number <> 0 Then Err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("excel.application") bExcelOpened = False Else bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = True Set oExcelWrkBk = oExcel.Workbooks.Open(sXlsFile) DoEvents Set oExcelWrSht = oExcelWrkBk.Sheets(WrSht) oExcelWrSht.Activate Set db = CurrentDb Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot) With rs If .RecordCount <> 0 Then .MoveFirst oExcelWrSht.Range("f2").Value = "List Of New Monthly subscription( K4 )" oExcelWrSht.Range("j2").Value = Format(Date, "mmmm\.yyyy") oExcelWrSht.Range("f6").CopyFromRecordset rs oExcelWrSht.Range("f6").Select oExcelWrSht.Range("f1").Select Else MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" GoTo Error_Handler_Exit End If End With Error_Handler_Exit: On Error Resume Next oExcel.Visible = True rs.Close Set rs = Nothing Set db = Nothing Set oExcelWrSht = Nothing Set oExcelWrkBk = Nothing oExcel.ScreenUpdating = True Set oExcel = Nothing Exit Function Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Export_Excel_officena_by_aba_judy" & vbCrLf & _ "Error Description: " & Err.Description _ , vbOKOnly + vbCritical, "An Error has Occured!" Resume Error_Handler_Exit End Function استدعيها بهذا الشكل في النموذج مع تعديل الرقم حسب رقم الشيت لديك ... Dim sXlsFile As String sXlsFile = CurrentProject.Path & "\K6_Ded.xlsx" Call Export_Excel_officena_by_aba_judy(sXlsFile, "SELECT * FROM qry_Ded_K4_New_Excel", 1) قم بتعديل الرقم 1 الى ارقام الشيت لديك

شكرا جزيلا اخي الفاضل وزادك الله من علمه

السلام عليكم ورحمه الله وبركاته ... لو سمحتوا ابي مساعدتكم في تصميم وتحليل هـذا المشروع .. واتمنى ما تبخلون علي

أخي الكريم حتى لا يتم إهمال الموضوع والمتابعة له ، أنصحك بفتح موضوع جديد والإشارة الى هذا الموضوع إن كان له أي دور في حل مشكلتك. ثم حاول استخدام الزر <> في محرر المشاركة لإضافة الأكواد . ليسهل عليك وعلى المتابعين تمييز وقراءة الأكواد 🤗 . وإن شاء الله ستجد حلوووول كثيرة تعجبك.

ابشر استاذ @* بو يوسف* بس عطني وقت ومايصير خاطرك إلا الطيب .

تفضل استاذ @2saad المرفق بعد التعديل حسب ما فهمت . ووافني بالرد . New Microsoft3-1.rar

استاذ @طير البحر مشكور وبارك الله فيك هدية مقبولة . وفقك الله .

استاذ @soik225998 تفضل المرفق والشرح بعد التعديل.اضغط على الاسم بالصب فورم (البيانات)........ اذا كان هذا طلبك لا تنسى الضغط على افضل اجابة . ملحوظة : انا مسحت بعض الصور نظراً لكبر حجمها حتي يمكن رفع البرنامج . تجريبي_3-1.rar

الدالة، تتطلب النص وترتيب الدرجة في النص 1 للأول 2 للثاني: Option Explicit Function GetDeg(ByVal inText As String, DegSeq As Byte) As Variant Dim Pos1 As Integer, Pos2 As Integer Dim Deg As Variant GetDeg = "" If DegSeq < 1 Or DegSeq > 2 Then Exit Function Do While InStr(1, inText, " ") > 0 inText = Replace(inText, " ", " ") Loop Pos2 = InStr(1, inText, " درج") If Pos2 = 0 Then Exit Function If DegSeq = 2 Then Pos2 = InStr(Pos2 + 1, inText, " درج") If Pos2 = 0 Then Exit Function End If Pos1 = InStrRev(inText, " ", Pos2 - 1) If Pos1 > 0 And Pos2 > 0 Then Deg = Mid(inText, Pos1 + 1, Pos2 - Pos1 - 1) End If If IsNumeric(Deg) Then GetDeg = Val(Deg) End Function ضفه في ملفك أو انشئ ملف جديد ووحدة نمطية جديدة والصق الشفرة/الكود

مشاركة مع استاذ @عبد اللطيف سلوم تفضل استاذ @soik225998 محاولتي بتعديل مرفقك بطلبك . ووافني بالرد . تجريبي_3.rar

تفضل أخي قاعدة من تصميم أحد عمالقة المنتدى ومسامحة لم أتذكر الاسم . يعمل لدي بكفاءة ولايوجد به أخطاء . Backup.rar

جميل جدا أخي الفاضل @حسونة حسين هذا العمل إبداع وهذه مساهمتي للبحث في موضوعات منتدى الاكسل ولكن في مجال الويب حتى يمكن البحث بسرعة بمجرد الكتابة ولو في الموبايل بدون الحاجة إلى برنامج الأوفيس https://officena.net/team/mas/excel.html بالتوفيق للجميع دعواتكم