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

السلام عليكم .. الاخوة الافاضل الموضوع اليوم بسيط وسريع ويتحدث عن طريقة عمل قوائم مختصرة منبثقة من الازرار مثل الصورة التالية : الفكرة كلها ان عندى نموذج به الكثير من الازرار فبحثت عن طرق لاختصار الاوامر كلها فى زر او اثنين وبالتالى وصلت الى الفكرة التالية. اول خطوة عمل موديول جديد به الكود التالى : Sub MyMenu2() Dim Mnu As CommandBar, Itm As CommandBarControl Set Mnu = CommandBars.Add("", MsoBarPopUp, , True) Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To PDF": Itm.OnAction = "amr3" Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To Excel": Itm.OnAction = "amr4" Mnu.ShowPopup End Sub القائمة السابقة فيها امرين 2 فقط ويمكن زيادتها كما تريد بتكرار السطور وتغيير الاسماء , بالنسبة لAmr1 فى نهاية الجملة هو الامر المطلوب تنفيذه وسيتضح الموضوع من المثال المرفق . الخطوة الثانية : فى النموذج المطلوب تنفيذ الفكرة عليه , خلف زر الامر يتم وضع كود استدعاء للكود السابق كالتالى : Private Sub Command0_Click() MyMenu2 End Sub والنتيجة عند الضغط على الزر تنبثق القائمة كما فى الصورة السابقة . ملاحظات : قمت باضافة خيار آخر لاظهار القائمة وهو عن طريق الضغط على زر الفأرة الايسر مع زر الشفت فى نفس الوقت وستظهر القائمة ايضاً . يمكن تطبيق الطريقة فى التقارير والنماذج مع الاحتفاظ بالقائمة المختصرة الافتراضية الخاصة بزر الفأرة الأيمن وبالتالى سيصبح عند قائمتين مختصرتين اذا اردت الابقاء على الافتراضية . يجب تفعيل المكتبات الموجودة بالصورة حتى لا تواجه مشاكل . اترككم مع المثال لمزيد من التوضيح .. دمتم بخير Amr Magic Button.accdb

للتخلص من استخدام مكتبة الأوفس ومشكلة عدم التوافق يمكن عمل التالي -- الإعلان عن متغير غرضي عام (Object) بدلا من التخصيص لشريط الأدوات أو قائمة الأدوت (CommandBar, CommandBarControl). -- عمل قائمة دلالية بأرقم خيارات موقع الأدوات أو استخدام الرقم مباشرة.. Public Enum MsoBarPosition msoBarBottom = 3 '..Command bar is docked at the bottom of the application window. msoBarFloating = 4 '..Command bar floats on top of the application window. msoBarLeft = 0 '..Command bar is docked on the left side of the application window. msoBarMenuBar = 6 '..Command bar will be a menu bar (Macintosh only). msoBarPopup = 5 '..Command bar will be a shortcut menu. msoBarRight = 2 '..Command bar is docked on the right side of the application window. msoBarTop = 1 '..Command bar is docked at the top of the application window. End Enum '--- يكون الأعلان بهذه الطريقة Sub MyMenu2() Dim Mnu As Object, Itm As Object Set Mnu = CommandBars.Add("", MsoBarPopUp, , True) Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To PDF": Itm.OnAction = "amr3" Set Itm = Mnu.Controls.Add: Itm.Caption = "Export To Excel": Itm.OnAction = "amr4" Mnu.ShowPopup End Sub

السلام عليكم ورحمة اللة تعالى وبركاته تم طرح الموضوع مسبقا >>----> هنا ولكن بدأ باستفسار من الاستاذ @أبو أحمد عن مجرد ادراج ملفات الصوت للاستماع اليها ثم تطرق بعد ذلك لسؤال عن شكل التصميم وطلب بعض التعديلات ولأهمية العمل من وجهة نظرى المتواضعة لكل من يريد استخدامه فى تعليم اخواننا ممن ابتلاهم الله بفقد البصر اولا اسال الله تعالى ان ينير بصيرتهم وايانا وكل امة محمد صل الله عليه وسلم ثانيا اسأل الله تعالى ان يتقبل هذا العمل المتواضع فيكتب بعد مماتى فى موازين اعمالى باب علم ينتفع منه وأخيرا المرفق الاصدار الثانى لا يعتمد على كائن مديا بلاير ولا على المكتبات التى تخصة لمن يواجه مشكلة مع الاصدار الاول ... وهو ما انصح به Braille.zip Braille V.0.2.zip

رسالة شكر لإخوتنا الكرام في قسم الأكسس على مبادراتهم الراقية السلام عليكم ورحمة الله وبركاته إخوتي الكرام ليس كل فاقد للبصر أعمى بل الأعمى الحقيقي هو ذاك الذي فقد بصيرته .... اللهم إنا نعوذ بك من عمى البصر وعمى البصيرة ، وهذا الأخير هو العمى الحقيقي ، أليس هناك من اجتمع له العميان والعياذ بالله حينما اعترض شاعر على حد من حدود الله تعالى بقوله: يقول أحد الشعراء : يد بخمس مئين عسجد وديت ما بالها قطعت في ربع دينار تناقضٌ ما لنا إلا السكوت له ونستعيذ بمولانا من النار شعر يدعي فيه أن الشريعة متناقضة يقول: إذا كانت دية اليد في حال قعطها خطأ خمس مائة دينار ذهب، وإذا سرقت ربع دينار تقطع فكيف هذا؟! فرد عليه أحد العلماء الكرام: قل لل........ عارٌ أيما عارِ جهل الفتى وهو عن ثوب التقى عاري لا تقدحن بنود الشرع عن شبهٍ شعائر الدين لم تقدح بأشعار يد بخمس مئين عسجد وديت ما بالها قطعت في ربع دينار عز الأمانة أغلاها وأرخصها ذل الخيانة فأفهم حكمة الباري جزاكم الله خيراً على إيجاد سبل لتعليم المكفوفين إخوتي الكرام في قسم الأكسس لكم مني جزيل الشكر على مبادراتكم الرائعة والسلام عليكم ورحمة الله وبركاته.

ايه يا ابو جودي ، اشمعنى الاستاذ عمرو يحصل على باقة ورد جميلة وكبيرة ، وهو صحيح انه يستاهل 🥰 بس اشمعنى يعني 😁 جعفر

تفضل التعديل يابو الحسن الدائن و المدين.zip

السلام عليكم اخى ومعلمى وشيخنا الجليل بعد الاطلاع عالرابط الاخير بحثت ووجدت لك هذا لعله يفيدك ان شاء الله https://sqlbackupandftp.com/blog/how-to-automate-mysql-database-backups-in-windows

اخ محمد بارك الله فيك .. العمل كله تمام باقي نفطة واحدة فقط وهو عند تغيير ( ملف العميل ) من 100 الى 200 لا يوجد تأخير في ملف العمل 200 .. ولا جمع متأخرات بل المتأخرات 0 ‫للارسال.xlsm

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

هذا هو الرابط : https://drive.google.com/file/d/1wfb_sWZGIgooWAApnkGk4emJCSXT9Ho2/view ويمكنك تحميله من هنا لو تعذر الرابط : برنامج الحضور والانصراف.rar

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

السلام عليكم اذا قصدك انه عند ادخال قيد جديد يكون النوع حديث الامر يسير بحيث يظهر في مربع التحرير دوما = حديث ،، ويمكنك التبديل اذا اردت في خصائص حقل النوع / افتح لسان التبويب : بيانات / في القيمة الافتراضية اجعلها = "حديث"

السلام عليكم تفضل الكود وهو لاحد الاخوة بالموقع انسخة في وحدة نمطية وبصراحة لااعرف عملة القرش Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim MyNo As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then MyNo = Mid$(GetNo, i + 1, 3) Else MyNo = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(MyNo, 1, 3)) > 0 Then RdNo = Mid$(MyNo, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(MyNo, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(MyNo, 2, 1) My10 = MyArry2(RdNo) If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function ثم قم ياستدعائة من حقل المبلغ المطلوب بالكود التالي Me.المبلغ_كتابه = NoToTxt(Me.المبلغ, "جنيه", "قرش") Database1.accdb

وعليكم السلام ورحمة الله تعالى وبركاته سلم يارب سلم اللهم إنا نعوذ بك من عمى البصيرة اللهم لا تزغ ابصارنا وثبت قلوبنا على طاعتك وخشيتك والوجل والخوف منك والرجاء فيك يا ارحم الراحمين

مشاركة مع اساتذى العظماء.... واثراء للموضوع هذا حل آخر يعتمد على الكود الاتى داخل الموديل ولاكن لابد من تفعيل المكتبة الاتية Microsoft ActiveX Data objects 2.1 library Function CollectFields(pstrSQL As String, Optional pstrDelim As String = ", ") As String Dim rs As New ADODB.Recordset rs.Open pstrSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic Dim strConcat As String With rs If Not .EOF Then .MoveFirst Do While Not .EOF strConcat = strConcat & .Fields(0) & pstrDelim .MoveNext Loop End If .Close End With Set rs = Nothing If Len(strConcat) > 0 Then strConcat = Left(strConcat, Len(strConcat) - Len(pstrDelim)): CollectFields = strConcat End Function بعد ذلك نقوم بعمل استعلام تجميعى ومصدر الاستعلام الجدول TblDowntime لانه به كل البيانات ولاننا نريد تجميع البيانات التى تخص كل Machines سوف نقوم بادارج الحقل الدال على ذلك وهو Machine لانه الذى يمثل العامل المشترك الذى يتم تجميع البيانات بناء عليه والان نريد تحميع كل البيانات التى تخص الـمدة Duration من كل السجلات نضع الجملة الاتية والتى نستدعى بها الكود من داخل الموديول لكل حقل نريد تجميع بياناته CollectFields("SELECT x1 FROM x2 WHERE x2='" & [x3] & "'" & " ORDER BY x3") x1--- اسم الحقل الذى نريد تجميع بياناته x2--- اسم الجدول او الاستعلام والذى هو مصدر البيانات x3--- اسم الحقل الذى يمثل العامل المشترك الذى يتم تجميع البيانات بناء عليه Downtime (2).accdb

واياكم اخى بالتوفيق

اتفضل الملف مره اخرى اختار اسم الماده متكتبش كودها 2025_1.accdb

وعليكم السلام اتفضل اخى @حسين العربى =IIf(Len([fary_1]![ddd] & "")=0;0;[fary_1]![ddd]) بالتوفيق test3.accdb

بارك الله فيك اخى الكريم , شرفنى مرورك وكلماتك العطرة

السلام عليكم ورحمة الله وبركاته مباركة عليكم الترقية أخي الكريم تقبل تحياتي العطرة لشخصكم الكريم والسلام عليكم

شكرا لكم استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل انا لم اكن اعلم اى شئ مما سبق ولكن لما دعت الحاجة لتصميم تلك القاعدة هذا ما استطعت فهمه بقليل من البحث عبر صفحات الانترنت حول تلك الطريقة فعلا الموضوع صعب ولكن ادركت وقتها نعمة البصر والاكثر منها البصيرة ... عند البحث وجدت هذا البيت واثر فى وجدانى كثيرا مِسكينٌ هوَ لا يَرى الألوانَ الرائِعَة بَل مسكينٌ أنتَ عيونٌ لكَ ونظراتُها ضائعَة

بارك الله فيك استاذنا الفاضل

تمام ابو جودي شكرا لك شرح بسيط وافي ومتكامل .. وصلت المعلومة

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

التعديل الذي تم هو في الصفحة الرئيسية طبق نفس التعديل على صفحة اضافة قيد جديد فقط

ولك مثله اخى الكريم , شرفنى مرورك

الف مبروك استاذنا الفاضل عمر وفقك الله ونفع بك وبعلمك 🌹

شكراً لك اخي ووفقكم الله وزادكم علماً

الف مبرووووك استاذنا 🌹 والى الامام دائما باذن الله 👍

استاذنا الغالى حسام بارك الله فيك ورفع قدرك

Private Sub Worksheet_Change(ByVal Target As Range) Dim sh As Long, v As Long, r As Long, lr As Long, i As Long, ii As Long If Target.Address = "$Q$4" Then Application.ScreenUpdating = False Application.EnableEvents = False Range("A10:T60000") = "" sh = Worksheets.Count: v = 10 For r = 1 To sh If Sheets(r).Name <> ActiveSheet.Name Then lr = Sheets(r).Range("i" & Rows.Count).End(xlUp).Row For i = 10 To lr If Range("Q4") = Sheets(r).Cells(i, 9) Then Cells(v, 1).Resize(, 20).Value = Sheets(r).Cells(i, 1).Resize(, 20).Value v = v + 1 End If Next i End If Next r Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

نعم ، هذه طريقة ، والمنتدى به الكثير من الطرق الاخرى مباشرة من الاكسس ، لإستيراد بيانات الاكسل الى الاكسس ، سواء من مجلد به ملفات اكسل مختلفة ، او من اوراق (sheet) مختلفة من نفس ملف الاكسل 🙂 المهم محتاجين نعرف ان هذا الملف/الورقة للقسم الفلاني ، سواء من اسم الملف او اسم الورقة ، وبدون المساس بالملف/الورقة ، وبرمجيا نسجل القسم في جدول الاكسس 🙂 جعفر

السلام عليكم .. اعتقد ان الطريقة مبشرة فعلا ومناسبة جدا لمطلب استاذنا ابو خليل , بارك الله فيك وزادك علماً

تفضل هذا التعديل Microsoft Access3.zip

وعليكم السلام 🙂 واهلا وسهلا بك في المنتدى 🙂 للاستفادة القصوى من المنتدى ، رجاء قراءة قوانين المنتدى: اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة استخدم ="#https://www.google.com/maps/place/" & [N] & " " & [E] . هذا مثال عملته الآن ، مع مراعاة الحقلين من نوع HyperLink ، ومصدر البيانات من النموذج وليس الجدول : . والنتيجة . جعفر 1466.HyperLink URL.accdb.zip

من الطبيعي ان تواجه مشكلة من الطبيعي ان تتوقف الجداول عن اضافة المزيد من الحقول اخي عدد الحقول لكل جدول هو 255 عمود بعد الوصول للحد الاقصى فلن تكون قاعدة البيانات قابلة للتعديل لكي تتجاوز هذه المشكلة فإن ايسر الحلول و اسهلها انشاء جدول جديد من خلاله تستطيع اضافة حقول تتجاوز العشرة آلاف لكن بالطرق السليمة الصحيحة ومن خلال ربط الجدول الجديد مع الحالي تكون قد حققت الهدف بعيد عن التحميل الغير منطقي على قاعدة البيانات و تكون النتيجة بهذا الشكل تم الاستغناء عن 236 حقل و التعويض عنها بعدد 4 حقول مترابطة سليمة حين يكون العمل بالصورة السليمة سوف تجد سهولة في التعامل مع طبق التعديلات تطبيقا منطقيا و اعد رفع الملف ان واجهت مشكلة اخرى التسويات 8-2022.zip

السلام عليكم ورحمة الله وبركاته أخي الكريم أرجو أن يكون المطلوب في الملف المرفق شيت المديرية الصف الرابع الابتدائي لغات.xlsm

=COUNTIF($A$2:A8;C5&"*?")

السلام عليكم ورحمة الله الكود الاتى يحسب الترتيب حتى العشرة الاوائل Sub AllRanks() Dim ws As Worksheet, j As Long Dim Arr As Variant, k As Double Dim LR As Long, i As Long Dim m As Integer, n As Integer, x As Integer Set ws = Sheets("مسودة الدرجات") LR = ws.Range("R" & Rows.Count).End(3).Row Dim TP() ReDim Arr(1 To LR, 1 To 1) j = 9 Do While j <= LR y = WorksheetFunction.CountIf(ws.Range(ws.Cells(9, "R"), ws.Cells(j, "R")), ws.Cells(j, "R")) If y = 1 Then i = i + 1 Arr(i, 1) = ws.Cells(j, "R") End If j = j + 1 Loop If i <= 10 Then x = WorksheetFunction.Large(Arr, i) End If ReDim TP(1 To i, 1 To 1) For r = 1 To i If Arr(r, 1) >= x Then p = p + 1 TP(p, 1) = Arr(r, 1) End If Next m = 9 Do While m <= LR For n = 1 To i k = WorksheetFunction.Large(TP, n) If ws.Cells(m, "R") = k Then yy = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") If ws.Range("R" & m) <> Empty Then If WorksheetFunction.CountIf(ws.Range("R9:R" & m), ws.Range("R" & m)) > 1 Then yy = yy & " " & "مكرر" ws.Cells(m, "U") = yy Else yy = yy ws.Cells(m, "U") = yy End If End If End If Next m = m + 1 Loop End Sub