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

السلام عليكم ورحمة الله وبركاته .. وبدون مقدمات 🙂 يطيب لي أن أضع بين يديكم برنامج ( مكتبة الأكواد الخاصة ) كان الهدف من تصميم البرنامج أن يخدمني بشكل خاص وذلك لحفظ الأكواد التي أحتاجها بشكل دائم وتجميعها في مكان واحد وتسهيل عملية البحث والوصول إليها بكل سهولة .. والبرنامج به تجميعة طيبة من الأكواد بعضها مما أبدعه الشباب هنا وبعضها مما صنعتها بنفسي ومنها من مواقع مختلفة .. والآن أحببت أن أشارككم بها وأن تعم الفائدة للجميع 🙂 البرنامج طبعا مفتوح بأحلاسه وأقلاسه ( بنماذجه وأكواده ) 😁 ويوجد فيه خاصية البحث ، وإدراج مرفقات (خارجية طبعا ) ومتاح للتطوير والتعديل والزيادة وتطويعه حسب احتياجاتكم .. 🌹 :: ولا تنسوني من صالح دعواتكم :: Pleeeeeeeeeeeeeeese 😄🤲🌷🌹 (واجهة البرنامج) (نافذة تفاصيل الكود) أعتقد البرنامج ما محتاج شرح واضح وضوح الشمس 😁 ::والتحميل في المرفقات :: مكتبة الأكواد الخاصة.accdb

السلام عليكم ورحمة الله وبركاته.. اقدم لكم مجموعة من واجهات المستخدم (user interface) عسى ان تفيدكم في تحسين مظهر البرامج الخاصة بكم. المصدر: https://github.com/krishKM/Modern-UI-Components-for-VBA لا تنسوني ووالدي من صالح دعائكم.. تحميل المرفق الأول: sample_x64.zip تحميل المرفق الثاني: sample_x86.zip

السلام عليكم ورحمة الله وبركاته.. كما في العنوان هذه بعض من دوال الاكسس VBA عسى ولعل تفيدكم. Public Function createFolder(path As String, Optional failIfAlreadyExists As Boolean = False) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then FSO.createFolder path End If If folderExists(path) Then createFolder = True Else createFolder = False End If GoTo handleSuccess Exit Function handleSuccess: GoTo cleanUp Exit Function handleError: If Err.Number = 58 And Not failIfAlreadyExists Then createFolder = True Else Call fileSystem.handleError(Err.Number, Err.Description, "createFolder()", path) End If GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function deleteFile(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" And fileExists(path) Then FSO.deleteFile path Else Exit Function End If If fileExists(path) Then deleteFile = False Else deleteFile = True End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path) GoTo cleanUp Exit Function cleanUp: Set FSO = Nothing Exit Function End Function Public Function deleteFolder(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" And folderExists(path) Then path = IIf(Right(path, 1) = "\", Left(path, Len((path)) - 1), path) FSO.deleteFolder path Else Exit Function End If If folderExists(path) Then deleteFolder = False Else deleteFolder = True End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function driveExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then driveExists = FSO.driveExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "driveExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function fileExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then fileExists = FSO.fileExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "fileExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function folderExists(path As String) As Boolean On Error GoTo handleError Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If path <> "" Then folderExists = FSO.folderExists(path) End If GoTo handleSuccess Exit Function handleSuccess: Call fileSystem.handleSuccess GoTo cleanUp Exit Function handleError: Call fileSystem.handleError(Err.Number, Err.Description, "folderExists()", path) GoTo cleanUp cleanUp: Set FSO = Nothing Exit Function End Function Public Function getComputerName() getComputerName = Environ("COMPUTERNAME") End Function Public Function getUserDesktopPath(Optional endWithSlash As Boolean = True) getUserDesktopPath = getUserProfilePath & "Desktop" & IIf(endWithSlash, "\", "") End Function Public Function getCurrentUsername() getCurrentUsername = Environ("USERNAME") End Function Public Function getUserProfilePath(Optional endWithSlash As Boolean = True) getUserProfilePath = Environ("USERPROFILE") & IIf(endWithSlash, "\", "") End Function Public Function getHomeDrive() getHomeDrive = Environ("HOMEDRIVE") End Function Public Function getHomePath(Optional includeDrive As Boolean = True, Optional endWithSlash As Boolean = True) getHomePath = IIf(includeDrive, getHomeDrive, "") & Environ("HOMEPATH") & IIf(endWithSlash, "\", "") End Function '''''''''''''''''''''''''''' ' ' Name: contains() ' Library: Strings.accda ' Author: Wyatt Castaneda ' Last Update: 23-Mar-19 ' Description: Searchs an arbitary number of strings for a substring ' ' Example(s): contains("wyatt", "wyatt", "james", "amber") --> true ' contains("scott", "wyatt", "james", "amber") --> false ' '''''''''''''''''''''''''''' Public Function contains(toCheck As String, ParamArray searchTerms()) As Boolean Dim term As Variant contains = False For Each term In searchTerms If InStr(toCheck, term) <> 0 Then GoTo doesContainString End If Next Exit Function doesContainString: contains = True Exit Function End Function Public Function lowerCase(toFix As String) As String On Error GoTo failGracefully lowerCase = StrConv(toFix, vbLowerCase) Exit Function failGracefully: lowerCase = toFix Exit Function End Function Public Function upperCase(toFix As String) As String On Error GoTo failGracefully upperCase = StrConv(toFix, vbUpperCase) Exit Function failGracefully: upperCase = toFix Exit Function End Function لا تنسوني ووالدي من صالح دعائكم.

وعليكم السلام -يمكنك استخدام هذه المعادلة =IF(COUNTIFS($B$2:$B$200,B2,$C$2:$C$200,C2,$D$2:$D$200,D2,$E$2:$E$200,E2)>1,"مكرر","") Countifs.xlsx

تفضل أخي الكريم Sub test() Dim A As Variant: Dim w As Variant Dim i As Long: Dim ii As Long A = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 1 To UBound(A) If Not .exists(A(i, 1)) Then .Add A(i, 1), Array(A(i, 1), A(i, 2), A(i, 3), A(i, 4)) Else w = .Item(A(i, 1)) For ii = 1 To UBound(w) w(ii) = w(ii) + A(i, ii + 1) Next .Item(A(i, 1)) = w End If Next Cells(6, 7).Resize(.Count, UBound(A, 2)) = Application.Index(.items, 0, 0) End With End Sub جمع المكرر.xlsm

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

Sub Test() Dim a, ws As Worksheet, rng As Range, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) m = ws.Cells(Rows.Count, "B").End(xlUp).Row Set rng = ws.Range("B3:B" & m) rng.Offset(, 1).Formula = "=kh_Names($B3,1,2)" rng.Offset(, 2).Formula = "=kh_Names($B3,1,2,3)" rng.Offset(, 3).Formula = "=kh_Names($B3,1,2,3,4)" rng.Offset(, 4).Formula = "=IF(COUNTIF($C$3:$C$" & m & ",C3)>1,COUNTIF($C$3:$C$" & m & ",C3),C3)" rng.Offset(, 5).Formula = "=IFERROR(IF(VALUE(F3)>1,IF(COUNTIF($D$3:$D$" & m & ",D3)>1,COUNTIF($D$3:$D$" & m & ",D3),D3),""""),"""")" rng.Offset(, 6).Formula = "=IFERROR(IF(VALUE(G3)>1,IF(COUNTIF($E$3:$E$" & m & ",E3)>1,COUNTIF($E$3:$E$" & m & ",E3),E3),""""),"""")" With rng.Offset(, 7) .Formula = "=CONCATENATE(IF(AND(ISTEXT(F3),F3<>""""),F3,""""),IF(AND(ISTEXT(G3),G3<>""""),G3,""""),IF(AND(ISTEXT(H3),H3<>""""),H3,""""))" a = .Value rng.Offset(, 1).Value = a End With ws.Columns("D:I").ClearContents Application.ScreenUpdating = True End Sub

محتاج معادلة بحيث ان تكون بعد النتيجة النهائية الا يقل الرقم عن 5 مثلا كما هو نوضح بالملف Book1.xlsx

تكرم أخي Book1.xlsx

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

السلام عليكم انت اللي جبته لنقسك - اسمع شرح الصعايدة - وامرك لله بس علي شرط لو لم تتفهم من الشرح شىء - عليك الاستعانة بالله أولا - ثم قم بشراء قاموس مفرادات اللهجة الصعيدية ولا تطلب الاعادة. توكلنا علي الله 1- في هذا السطر بنعرف دالة عامة - حتي نستطيع ان ننادي عليها من اي مكان بالبرنامج 2- لماذا دالة وليس اجراء؟! يعني لماذا Function وليس Sub ؟! 3- نعم لأن الدالة يمكن تحويلها الي قيمة وهذا ما حدث هنا فقد تم تحويل هذه الدالة الي قيمة منطقية ( True - False) فبعد ان تنتهي دالتنا من مهمتها ستتحول الي قيمة true في حالة الانتهاء من مهمتها بنجاح والا الي false 4- وكنا بحاجة الي تمرير اسم الفورم الذي ستتعامل معه دالتنا فكان لا بد من وضع بارمتر للدالة لنمرر قيمة هذا البارمتر عند منادة الدالة من الفورم - وعلي حد علمي يمكن تمرير البارمتر بطريقتين: أ- ByVal = وبهذه يتم تمرير القيمة للبارمتر - بحيث نخبر الدالة ان تتعامل مع هذا البارمتر كقيمة مثلا: عندما امرر اسم مربع نص لهذا البارمتر من الفورم فستقوم الدالة بالتعامل مع النص الذي بداخل مربع النص (ارجو ان يكون الأمر واضح) ب- ByRef = وهذه تتعامل مع كائن المرر علي اعتباره وليس علي اعتبار قيمته ، مثلا: بالمثال السابق عند تمرير اسم مربع النص سيتم التعامل مع مربع النص كمربع نص - يعني ككنترول - وليس كرقم او نص الذي بداخل هذا الكنترول لا تنسي الشرط - والقاموس اما عن C فكنت قد عرفته في جزء التعريفات العام ولم ارفق هذا الجزء بالكود ولم انتبه الا عند ممارستي لهواية الشرح وكان تعريف الـ c هكذا Dim C As Control وهكذا لا حاجة لتوضيح شىء آخر عن هذه النقطة والحمد لله اما عن باقي الكود فهذا لا يحتاج الي شرح اليس كذلك وعلي كل وان كنت مصر فهذا هو مدار الكود ان يتم التحقق من كل كنترول مظنة اداخل البيانات منه مثل: textbox - أو - combobox ان كان يحمل تاج * هل هو فارغ ام لا ان كان فارغ يعطي الدالة قيمة false وينهي الاجراء ويظهر رسالة ويظلل خلفية هذا الكنترول بلون اصفر وضع التركيز عليه ولا تسأل لماذا اللون الأصفر لأني لا أدري لماذا أفضله أعتقد ان الشرح قد انتهي وأسأل الله أن ييسر لكم فهم ما قلت ولا تنسي شرطنا واتفاقنا منذ البداية تمنياتي بالتوفيق

I3 =IF(ROUNDUP(H3/0.25;0)*0.25<=5;5;ROUNDUP(H3/0.25;0)*0.25) السلام عليكم أخي الكريم أرجو أن يكون هذا هو الحل في الخلية I3

السلام عليكم أخي الكريم كنت أتمنى أن يكون هناك عملاً أفضل مما سأقدمه لك لكن ريثما يكون ذلك إليك هذا الحل... تنسيق شرطى.xlsm

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

وعليكم السلام 🙂 جميل اخوي الخبير موسى 🙂 جعفر

استاذ كبير وعبقرى وخبير

تفضل - نفس كود الاستاذ محي - اجراء بعض التعديل جمع المكرر (1).xlsm

جزيت خيرا اشتغلت المعادلة

السلام عليكم 🙂 تفضل : بالنسبة للبحث ، اضفت هذا الحقل بالحقول المطلوبة ، فتقدر تضيف وتنقص منها اللي يناسبك : . وهذه الاكواد: Private Sub cmd_New_Student_Click() 'عمل سجل جديد DoCmd.GoToRecord , , acNewRec Me.namestudent.SetFocus End Sub Private Sub SearchList_DblClick(Cancel As Integer) 'عند النقر مرتين، الانتقال الى اسم الطالب Me.Recordset.FindFirst "codestudint=" & Me.SearchList Me.Bookmark = Me.Recordset.Bookmark Me.namestudent.SetFocus End Sub Private Sub srch_txt_AfterUpdate() 'البحث في Listbox Me.SearchList.Requery End Sub . اما زر حفظ ، وحفظ التعديل ، فلم يتم استعمالهم 🙂 جعفر 1488.Microsoft.accdb.zip

بارك الله فيكم لقد تم التوصل للحل عن طريق تحوي الحقل من رقم عشري الى رقم ثابت

اذا اكتب الكود بهذا الشكل في حدث عند الخروج ووافنا بالنتائج Private Sub Form_Close() If TestRequeredField(Me) = False Then Me.Undo End If End Sub

السلام عليكم ورحمة الله وبركاته اولا - أنشأ موديل وضع به هذا الكود Public Function TestRequeredField(ByRef frm As Form) As Boolean 'Elhlawany 21/12/2021 'test if control is marked with * or not On Error Resume Next For Each C In frm.Controls If C.ControlType = acTextBox Or C.ControlType = acComboBox Then If C.Tag = "*" And Len(C & "") = 0 Then C.BackColor = vbYellow C.SetFocus msgbox "This is Required Field you must fill it!" 'MakeMsg (45) TestRequeredField = False Debug.Print C.Name Exit For Exit Function Else TestRequeredField = True End If End If Next End Function ثانيا- من خصائص الحقل او الحقول التي تريد التحقق منها اضبط خاصية التاج الي نجمة بهذا الشكل ثالثا- في زر الحفظ ضع هذا الكود If TestRequeredField(Me) = True Then 'Write here what you want happin Else Beep End If ودمتم ولا تنسانا من دعواتك

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

السلام عليكم أخي الكريم أي تحديد (اختيار ) حالة حسب الكود المطلوب مثال: تحديد حالة ( نعم أو لا أو إلغاء الأمر) تعريف متغير باسم nResult كنتيجة VbMsgBoxResult أي مربع رسالة بعرض النتيجة مربع رسالة بعرض النتيجة = رسالة ( نعم أو لا أو إلغاء الأمر) نحدد حالة nResult كما يلي: في حالة nResult النتيجة نعم أظهر "نعم" في حالة nResult النتيجة لا أظهر "لا" في حالة nResult النتيجة إلغاء أظهر "إلغاء" ثم نهاية التحديد في الكود ثم إتمام الكود Sub Select_Case_Yes_No_Cancel() Dim nResult As VbMsgBoxResult nResult = MsgBox("...", vbYesNoCancel) Select Case nResult Case vbYes MsgBox "Yes" Case vbNo MsgBox "No" Case vbCancel MsgBox "Cancel" End Select End Sub تقبل تحياتي العطرة والسلام عليكم

السلام عليكم المعذرة على التاخير بسبب تغيير سياسة الدخول للمنتدى بامكانك استخدام المعادلة ادناه =(INT(A2/60)&":"&A2-(INT(A2/60)*60))&":00" انظر للملف المرفق واي استفسار خبرني من فضلك مع الشكر تحويل الدقائق إلى ساعات (1).xlsx

حيا الله اخي السيد جمال الموضوع مش راضي افهمه والله مش عارف ليش حسب فهمي : انا كمبرمج لدي حساب في الدروب بوكس وبه ملفين واحد ملف نصي علشان اعرف هناك تحديث وملف اخر وهو ملف الاكسس الجديد ؟ الاسئلة : هل سيكون لكل عميل حساب دروب بوكس خاص به ؟ ماذا عن بياناتي السابقة وفي الملف الحالي لدي وكعميل .. هل سيتم نقل البيانات الحالية للاصدار الجديد ؟ ولو كان هناك تغيرات في بنية الجداول ؟ تحياتي