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

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

دالة DLookup لابد للحصول على نتيجة صحيحة ان نستخدم معها معيار فريد وبالتالي عند استخدام between فسوف تعود الدالة باول سجل مطابق فقط لذا فمن الافضل التفكير باستخدام معيار اخر اما اذا كنت مصمم على هذا الاستخدام الغير صحيح DLookup("[pcode]", "lab_all", "[pcode]between 2 and 6 ") اخونا الشايب

انصحك بوضع المرفق لايضاح الرؤية لان الاجابات والافكار بتختلف تبعا لاسلوب والية الاكواد والافكار فى التصميم كده هنفضل نلف حوالين نفسنا وياك من غير مرفق

اعتقد حسب فهمي للسؤال ان المطلوب منع التعديل على مربع الاختيار وبما ان الهدف هو منع التعديل على مربع الاختيار فيمكن ان تتم حمايته من التعديل ويتم تفعيله آليا عند اختيار نوع المستخدم = admin اما اذا اردنا هذا المربع متاح لأي نوع من انواع المستخدمين حسب الحاجة .. وفي الوقت نفسه نريد حمايته عن التعديل للمستخدم admin فهذا الكود يفي بالغرض : Private Sub userID_BeforeUpdate(Cancel As Integer) If Me.userType = "Admin" Then MsgBox "لا يمكن التعديل" Undo DoCmd.CancelEvent Exit Sub End If End Sub على اعتبار userID هو مربع الاختيار وهذا مرفق للتجربة AA.mdb

جرب Database1121.accdb

السلام عليكم ورحمة الله تعالى وبركاته نظرا للطلب والتساؤلات الكثيرة حول الموضوع او نقاط فرعيه منه قاصدا من ذلك أن يكون الموضوع شاملا ومرجعا للراغبين فى ذلك والدراسبن اليكم بناء القاعدة والذى اتمنى على الله تعالى ان يبدأ البناء وينتهى بشكل احترافى بقدر الإمكان وسوف نبدأ من الصفر تباعا ان شاء الله سوف يتم تحديث الموضوع تباعا الموضوع بأمر الله سوف اضع له الخطوط العريضة طبقا للمؤسسة التى اعمل بها لاننى أصلا سوف اقوم بقاعدة البيانات لمؤسستى وبقدر الإمكان سوف أضع فى الحسبان ان يكون التصميم عام بقدر الإمكان ليتناسب ويتماشى مع الجميع ومع رغباتهم بقدر الإمكان اهلا بكل من يريد المشاركة فى ادراة الموضوع والافكار والتعديل او الاضافة و ...... مبدئيا خلونا نتفق وقتى ضيق فى الفترة المقبلة لما انا مقدم عليه فلذلك ارجو الاعتذار مقدما ان لم التفت الى اى تساؤلات والتى وإن حدث سوف يتم تأجيلها حتى ينتهى مشروع اعداد التطبيق لمؤسستى تماما ان شاء الله بسم الله وعلى بركة الله بداية المشروع اول شئ تصيد وتسجيل الاخطاء بجدول وده وظيفته تسجيل الحطأ باسم الحدث أو الدالة المستخدمة فى الكود عند تنفيذ امر ما ورقم الخطا وصفه للمساعدة مستقبلا فى الوقوف على اماكن الاخطاء لعمل الصيانة اللازمة طبعا تم التطرق اليه فى هذا الموضوع: ويمكنكم الذهاب اليه والمتابعة من هنا طيب حلو جدا جدا وعلشان انا هبدأ بالأكواد ملاحظات هامة جدا جدا جدا جدا لبداية صحيحة واحترافيه : كتابة كود احترافي تتطلب ممارسات جيدة واتباع مبادئ برمجية صحيحة. فيما يلي بعض النصائح التي يمكن أن تساعدك في كتابة كود احترافي: توضيح الكود: استخدم تعليقات لشرح الجزء العلوي من الكود وللأمور المعقدة. اختر أسماء مفيدة وواضحة للمتغيرات والدوال تدل على وظائفها التى تمت كتابتها من اجلها. التنظيم: استخدم الهندسة المعمارية لتنظيم البرنامج إلى وحدات صغيرة وقابلة لإعادة الاستخدام. قم بتقسيم البرنامج إلى وحدات ووظائف مستقلة. الأداء: ابتعد عن الأكواد المكررة وقدّم الأكواد القابلة لإعادة الاستخدام في وحدات. حافظ على الأداء بتجنب العمليات الزائدة غير الضرورية. اختبار الوحدات: قم بكتابة اختبارات للتأكد من أن وحدات الكود الخاصة بك تعمل كما هو متوقع. الأمان: تحقق دائمًا من صحة البيانات الواردة والخارجة من الدوال. تفادى استخدام الأكواد المعرضة لثغرات أمان. تحسين الأداء: استخدم الهندسة العكسية لتحسين الأداء. ابحث عن فرص لتحسين الكفاءة والسرعة. استخدام التعليمات البرمجية النظيفة: ابتعد عن استخدام المتغيرات العالمية عندما لا تكون ضرورية. تجنب الأكواد التي تعتمد على التبديلات الطويلة. توثيق الكود: وفر توثيقًا جيدًا للكود ليسهل على المطورين الآخرين أو نفسك فهم كيف يعمل البرنامج. متابعة المعايير: اتبع معايير البرمجة المتعارف عليها . التحسين المستمر: كن مستعدًا لتحسين الكود الخاص بك بناءً على التعلم وتغييرات متطلبات المشروع. الالتزام بتلك المبادئ يمكن أن يساعدك في كتابة كود أكثر احترافية وقابل للصيانة. حلو الكلام وكل ده هيبان بقدر المستطاع فى التعليمات البرمجية التى سوف تتم تباعا يمكنك استخدام البادئات التالية لتسمية العناصر والكائنات بشكل منظم ويجعل الشيفرة أكثر وضوحًا. البادئات تعتمد على النوع أو الدور الذي تقوم به العناصر: وعلى سبيل المثال وليس الحصر المتغيرات: int للأعداد الصحيحة. dbl للأعداد العشرية. str للنصوص. bool للقيم البولية اى True , False أو Yes , No . Dim intCounter As Integer Dim dblAmount As Double Dim strName As String Dim boolIsValid As Boolean المصفوفات: arr للمصفوفات. Dim arrNames() As String الدوال: Function للدوال التي تعيد قيمة. Sub للإجراءات (دوال بدون إرجاع قيمة). Function CalculateTotal() As Double Sub DisplayMessage() الكائنات: frm للنماذج (Forms). rpt للتقارير (Reports). tbl للجداول (Tables). qry للاستعلامات (Queries). cls للكائنات أو الفئات لتعريف الكلاسات (Classes). bas وحدات الشيفرة- الوحدات النمطية (Modules). tbl للجداول (Tables). qry للاستعلامات (Queries). Dim frmCustomer As Form Dim rptSales As Report Dim tblData As TableDef Dim qryFilteredData As QueryDef الثوابت: c للثوابت. Const cMaxValue As Integer = 100 المتغيرات العامة: g للمتغيرات العامة. Public gCounter As Integer المتغيرات المؤقتة: temp للمتغيرات المؤقتة. Dim tempValue As Integer التعليقات: REM لتعليقات الشيفرة. REM هذا تعليق لشرح الشيفرة الأشكال والعناصر الرسومية: btn للأزرار (Buttons). lbl للتسميات (Labels). txt لحقول النص (Textboxes). chk لمربعات الاختيار (Checkboxes). القوائم والمراقبين: cmb لقائمة الاختيار (Comboboxes). lst لقوائم الاختيار (Listboxes). cb لمراقبات الصندوق (Checkboxes). الكائنات الأخرى: app لكائن التطبيق (Application). cnn لكائن الاتصال (Connection). doc لكائن المستند (Document). الحقول والأعمدة: fld لحقول البيانات (Fields). col لعمود البيانات (Column).

تحديث برنامج طبي متكامل مجاني كلمة السر 1 والاعدادات 123 يجب ان يستخرج المجلد في قرص D رابط التنزيل: https://drive.google.com/file/d/1AYN9Y768HIsNB1RWyZlLsiCtH32r-5z4/view?usp=drivesdk

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim wb As Workbook, WS As Worksheet, dest As Worksheet Set wb = ThisWorkbook: Set WS = wb.Sheets("Sheet1"): Set dest = wb.Sheets("Sheet2") Dim j&, col&, ligne&, r As String Dim Rng As Range: col = 12: r = dest.[B19] ligne = WS.Cells(Rows.Count, col).End(xlUp).Row With Application .ScreenUpdating = False dest.Range("C22", Range("AD" & Rows.Count).End(4)).ClearContents For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If Next j If Application.WorksheetFunction.CountA(dest.Range("C22:AD22")) = 0 Then MsgBox "غير موجود" & " / " & r, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True End With End Sub تجربة 2.rar

تمام لاستخراج الرموز بدون تكرار في ورقة ادخال البيانات الخلية P18 ضع المعادلة التالية مع سحبها للاسفل =IFERROR(INDEX($L$18:$L$200; MATCH(0; IF(ISBLANK($L$18:$L$200); 1; COUNTIF(P17:$P$17; $L$18:$L$200)); 0));"") مع تسمية النطاق بالشكل التالي وليكن مثلا Clé =OFFSET('ادخال البيانات'!$P$18;0;0;COUNT(IF('ادخال البيانات'!$P$18:$P$10000="";"";1));1) ولجلب البيانات استخدم الكود التالي Sub Search() Dim WSdata As Worksheet: Dim WSEntry As Worksheet: Set WSdata = Feuil1: Set WSEntry = Feuil2 Dim Clé As String, all As String, lr As Long, F&, Col& Dim a As Range, b As Range, rngCell As Range With Application .ScreenUpdating = False .Calculation = xlCalculationManual lr = WSdata.Cells(WSdata.Rows.Count, "C").End(xlUp).Row Clé = WSEntry.[G1]: all = "الكل" WSEntry.Range("A4:F500").ClearContents For Col = 4 To lr If WSdata.Cells(Col, "H") Like Clé Then Set a = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = a.Value End If If Clé Like all Then Set b = WSdata.Range(WSdata.Cells(Col, 3), WSdata.Cells(Col, 8)) WSEntry.Cells(Rows.Count, "a").End(xlUp).Offset(1, 0).Resize(, 6).Value = b.Value End If Next Col F = WSEntry.Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSEntry.Range("A4 :H" & F) WSEntry.Range("A4:H500").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSEntry.Range("A4:H5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية" & " / " & Clé, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub وفي حدث ورقة ادخال البيانات Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Target.Worksheet.Range("G1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call Search Application.EnableEvents = True End If On Error GoTo 0 End Sub ترحيل بيانات 7.xlsm

منكم نتعلم استاذى الجليل ومعلمى القدير هذا من فضل الله سبحانه وتعالى ثم لكلم ولكل اساتذتى العظماء تعرف يا استاذى انا تقريبا بطلت ستخدم DLookup الا فى اضيق الحالات كل ما اجى استخدمها افتكر كلمة استاذ @jjafferr سر قوة الاكسس فى الاستعلامات الان تقريبا اعيد ما اريد من خلال الاستعلامات بدلا من DLookup فعلا الاستعلامات رهيبة جدا جدا جدا جدا

شوف ردي السابق جرب احذف السطر الرابع والخامس

ماشاء الله عليك اخي محمد كفيت ووفيت 🌹

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

وبناء على قول استاذى الجليل ومعلمى القدير الاستاذ @شايب استخدم هذه الطريقة افضل من خلال استعلام SELECT * FROM TableName WHERE FieldName BETWEEN 50 AND 80;

في نفس المكان أكتب : 50 and 80 مع الأخذ في الإعتبار نصيحة شايبنا الكريم @شايب 🙂

صباح الخير ابا جودي ستكون الردود هنا شحيحة ، لأن التجربة ستكون لمن يملك أو يعمل على شبكة محلية

ضع هذا السطر أول الأوامر في زر الحذف : If Me.Admin = true Then Exit Sub 🙂

مع بعض التعديلات البسيطة Sub Find_And_copy() ' to Update 06 / 01 / 2024 Dim c As Range: Dim Col As Range Dim r As Range: Dim Rng As Range Dim WS As String: Dim j As Long Dim lastrow As Long: Dim MyData As Worksheet: Set MyData = Feuil2 On Error Resume Next If MyData.[H2] = "" Then: MsgBox "المرجوا إدخال تاريخ الغياب", vbInformation, "admin": Exit Sub lastrow = MyData.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If WorksheetFunction.CountA(MyData.Range("G4:G" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [G3], vbExclamation: Exit Sub If WorksheetFunction.CountA(MyData.Range("H4:H" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [H3], vbExclamation: Exit Sub For j = 4 To lastrow If MyData.Range("G" & j) <> "" Then: WS = MyData.Cells(j, "G") Set MyDest = Worksheets(WS) With Application .ScreenUpdating = False With MyDest For Each r In MyDest.Range("A5", .Cells(Rows.Count, 1).End(xlUp)) Set Rng = MyData.Range("A:A").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then For Each c In Application.Intersect(MyData.UsedRange, MyData.[H2]) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set Col = MyDest.Rows(3).Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) If Col Is Nothing Then: MsgBox "المرجوا التحقق من تاريخ الإدخال" & " : " & MyData.[H2].Value, vbInformation, "تعليمات": Exit Sub If Not Col Is Nothing And Rng.Offset(, 6).Value = MyDest.Name Then MyDest.Cells(r.Row, Col.Column).Value = Rng.Offset(, 7).Value End If End If Next c End If Next End With .ScreenUpdating = True End With Next j On Error GoTo 0 MyData.Range("G4:H" & lastrow + 1).ClearContents: [H2] = Empty MsgBox "تم ترحيل البيانات بنجاح ", vbInformation, "admin" End Sub ترحيل بيانات 6.xlsm

لتصميم الشاشة الرئيسية وسهولة التحكم فىيها تم اضافة جدول جديد باسم tblFormsTitle يتكون من الحقول FormName = اسم النموذج الفرعى FormDesc = وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) TitleForm = العنوان فى الشاشة الرئيسية البيانات داخل الجدول كالاتى اسم النموذج الفرعى وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) العنوان فى الشاشة الرئيسية frmHomeMenu HomeMenu الرئيسية frmSub1ImportOraclExcel ImportExcel استيراد بيانات الحضور والانصراف ( Oracle's Excel sheet ) frmSub2DailyEmployee DailyEmployee ادارة يوميات الموظفين ( اضافة / تعديل / حذف ) frmSub3QueryDaily QueryDailyBy استعلام وتقارير يوميات الموظفين frmSub4Employees EmployeesData ادارة بيانات الموظفين ( اضافة / تعديل / حذف ) frmSub5DailyLogsType DailyLogsType ادارة انواع اليوميات ( اضافة / تعديل / حذف ) frmSub6Department Department ادارة بيانات الادارات و المديرين ( اضافة / تعديل / حذف ) frmSub7Section Section ادارة بيانات الاقسام ( اضافة / تعديل / حذف ) تم تصميم النماذج الفرعية بدون اى مصدر بيانات .... عمل نموذج رئيسي باسم frmMain فى وضع التصميم تم اضافة نموذج فرعى غير منضم باسم subformControl تم اضافة مربع تسمية ( Lable ) باسم lblTitle اضافة عدد سبع ازرار باسماء btnNavItem1 ,btnNavItem2 , btnNavItem3 , ........ الخ عنصر تحكم صورة باسم imgArrow يحتوى على شكل سهم الاكواد فى النموذج قائمة بوظائف الازرار تبعا لوصف النماذج من الجدول والذى اشرنا الى الحقل الخاص به وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) ' Enum to define button actions Enum ButtonAction HomeMenu ImportExcel DailyEmployee QueryDailyBy EmployeesData DailyLogsType Department Section End Enum متغيرات لاسناد قيم اليها ' Declare variables to store form name and title Private strFormName As String Private strTitleForm As String Private subformInfoArray As Variant دالة لتحديد المعيار لجلب البيانات للنماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على Enum قائمة الازرار ' Sub to handle button click events Private Sub HandleButtonClick(btnAction As ButtonAction) Dim subformInfoResult As String ' Get subform information based on the button action subformInfoResult = GetSubformInfo(ButtonActionToString(btnAction)) ' Process the subform information and update the form ProcessSubformInfo subformInfoResult End Sub دالة لاحضار معلومات النماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على المعيار من الدالة السابقة ' Function to get the name and title of the subform based on the form description Function GetSubformInfo(subformDesc As String) As String ' Use On Error Resume Next to handle errors gracefully On Error Resume Next ' Declare a DAO Recordset variable Dim rs As DAO.Recordset ' Open a recordset based on the provided form description Set rs = CurrentDb.OpenRecordset("SELECT FormName, TitleForm FROM tblFormsTitle WHERE FormDesc='" & subformDesc & "'") ' Check if the recordset is not empty If Not rs.EOF Then ' Return the concatenated string of FormName and TitleForm GetSubformInfo = rs!formName & "," & rs!titleForm Else ' Return an empty string if no matching record is found GetSubformInfo = "" End If ' Close the recordset to free up resources rs.Close Set rs = Nothing ' Check for errors and display debug information If Err.Number <> 0 Then MsgBox "Error retrieving subform information: " & Err.Description, vbExclamation Err.Clear End If End Function دالة لفصل اسم النموذج والعنوان والذى تم الحصول عليهم من الدالة السابقة ' Sub to process subform information and update the form Sub ProcessSubformInfo(subformInfoResult As String) ' Split the subformInfo into an array subformInfoArray = Split(subformInfoResult, ",") ' Extract the formName and title from the array If UBound(subformInfoArray) >= 1 Then strFormName = Trim(subformInfoArray(0)) strTitleForm = subformInfoArray(1) End If ' Update the form based on the subform information UpdateFormBasedOnSubformInfo End Sub دالة للتحكم فى اظهار واخفاء موضع صورة سهم تدل على النموذج الفرعى تبعا لزر الامر ' Sub to move the arrow indicator on the form Sub MoveArrow() ' Make the arrow visible and position it below the active control If Not Me.imgArrow.Visible Then Me.imgArrow.Visible = True Me.imgArrow.Top = Me.ActiveControl.Top ChangeCommandButtonColor Me End Sub دالة تحديث النموذج بناء على المعطيات السابقة من الدوال بمجرد النقر على زر الامر ' Sub to update the form based on the subform information Sub UpdateFormBasedOnSubformInfo() Select Case Nz(strFormName, "frmHomeMenu") Case Is = "frmHomeMenu" Me.lblTitle.Caption = strTitleForm subformControl.Visible = False ChangeCommandButtonColor Me, False Me.imgArrow.Visible = False Me.subformControl.SourceObject = "" Me.subformControl.Height = 0 Case Else Me.lblTitle.Caption = strTitleForm MoveArrow ChangeCommandButtonColor Me Me.subformControl.Height = BoxMain.Height Me.subformControl.SourceObject = strFormName subformControl.Visible = True End Select End Sub الاكواد لضبط وتحديد الحدث المراد تنفيذه تبعا لازرار الاوامر ' Function to convert ButtonAction to corresponding form description Function ButtonActionToString(btnAction As ButtonAction) As String Select Case btnAction Case ButtonAction.HomeMenu: ButtonActionToString = "HomeMenu" Case ButtonAction.ImportExcel: ButtonActionToString = "ImportExcel" Case ButtonAction.DailyEmployee: ButtonActionToString = "DailyEmployee" Case ButtonAction.QueryDailyBy: ButtonActionToString = "QueryDailyBy" Case ButtonAction.EmployeesData: ButtonActionToString = "EmployeesData" Case ButtonAction.DailyLogsType: ButtonActionToString = "DailyLogsType" Case ButtonAction.Department: ButtonActionToString = "Department" Case ButtonAction.Section: ButtonActionToString = "Section" End Select End Function الاكواد على ازرار الاوامر Private Sub ImageLogo_Click() HandleButtonClick HomeMenu End Sub Private Sub btnNavItem1_Click() HandleButtonClick ImportExcel End Sub Private Sub btnNavItem2_Click() HandleButtonClick DailyEmployee End Sub Private Sub btnNavItem3_Click() HandleButtonClick QueryDailyBy End Sub Private Sub btnNavItem4_Click() HandleButtonClick EmployeesData End Sub Private Sub btnNavItem5_Click() HandleButtonClick DailyLogsType End Sub Private Sub btnNavItem6_Click() HandleButtonClick Department End Sub Private Sub btnNavItem7_Click() HandleButtonClick Section End Sub واخيرا وحدة نمطية باسم basChangeButtonColor خاصة بتغير لون زر الامر الذى يتم الضغط عليه فى النموذج الرئيسى ' Enum for colors Enum ColorEnum WhiteColor = 16777215 ' White RedColor = 255 ' Red GreenColor = 32768 ' Green BlueColor = 16711680 ' Blue PurpleColor = 8388736 ' Purple GrayColor = 8421504 ' Gray OrangeColor = 16753920 ' Orange BrownColor = 10824234 ' Brown BlackColor = 0 ' Black CyanColor = 16776960 ' Cyan MagentaColor = 16711935 ' Magenta YellowColor = 65535 ' Yellow LightBlueColor = 173216230 ' Light Blue DarkGreenColor = 65280 ' Dark Green PinkColor = 16761035 ' Pink LavenderColor = 230230250 ' Lavender OliveColor = 32896 ' Olive AquaColor = 65535 ' Aqua TurquoiseColor = 4251856 ' Turquoise GoldColor = 16766720 ' Gold SilverColor = 12632256 ' Silver MaroonColor = 8388608 ' Maroon NavyColor = 128 ' Navy TealColor = 8421376 ' Teal CoralColor = 5275647 ' Coral SalmonColor = 16416882 ' Salmon IndigoColor = 4915330 ' Indigo PeachColor = 16775640 ' Peach SiennaColor = 10506797 ' Sienna SkyBlueColor = 8900331 ' Sky Blue End Enum ' Module-level variables Dim currentButtonBackColor As Long ' Variable to store the current button back color Dim currentButtonForeColor As Long ' Variable to store the current button fore color Dim selectedButton As CommandButton ' Variable to store the selected button ' Subroutine to set the button color Sub SetButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing) ' Set new button colors Dim newButtonBackColor As Long Dim newButtonForeColor As Long newButtonBackColor = ColorEnum.GrayColor newButtonForeColor = ColorEnum.BlackColor If Not btn Is Nothing Then ' Store the current button's colors currentButtonBackColor = btn.BackColor currentButtonForeColor = btn.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = btn btn.BackColor = newButtonBackColor btn.ForeColor = newButtonForeColor End If End Sub ' Subroutine to change the button color Sub ChangeCommandButtonColor(frm As Form, Optional changeColor As Boolean = True) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl ' Store the default button colors before changing Dim currentButtonBackColor As Long Dim currentButtonForeColor As Long currentButtonBackColor = clickedButton.BackColor currentButtonForeColor = clickedButton.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Apply the button color if changeColor is True If changeColor Then SetButtonColor frm, clickedButton End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Resume Next Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox "Error: " & Err.Number & vbCrLf & "Description: " & Err.Description Resume ' Resume execution at the same line End Select End Sub المميزات : 1- عند الابتعاد عن الشاشة والعودة مرة أخرى بمجرد النظر يمكنك معرفة الزر الاخير الذى تم الضغط عليه 2-سهولة تغيير العناوين التى تظهر على الشاشة الرئيسية تبعا لكل نموذج فرعى بكل سهولة بدون داعى للدخول الى عرض التصميم من الجدول اختبار تجربة يتبع ... واخيرا المرفق HRManagement V 1.0.2.zip

السلام عليكم تفضل المرفق فيه ما تريد... ورقة عمل Microsoft Excel جديد (1).xlsx

جرب محاولتي: تقريب الدينار العراقي_01.xlsx

الان الجداول الاساسية المرفق بالجداول اللازمة HR Managment.zip

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

الكود صحيح وتضاف القيمة الجديدة في جدول BundleDataOut لم تبين المشكلة عندك .. وانت مضطر ترفق مثالك ليتم التعديل عليه .. فالاخطاء لديك لا يمكن اكتشافها الا من خلال المثال

السلام عليكم ورحمة الله وبركاته أخي الكريم توضيح فقط وهو أن دالة subtotal تعمل فقط مع اخفاء الصفوف ولا تعمل مع الأعمدة وهنا عليك استخدام هذه الصيغة =(CELL("width",E6)>0)*E6+(CELL("width",G6)>0)*G6+(CELL("width",I6)>0)*I6+(CELL("width",K6)>0)*K6 ولكن مع ملاحضة أن هذه الصيغة كلما أخفيت عمود أو أظهرت عمود يجب تحديثها أي تقف على الصيفة مثلا وتضغط F2 ثم تضغط Enter ويمكنك استخدام هذا الكود Public Function SumVisible(Rg As Range) As Double Dim xCell As Range Dim xRg As Range Dim xOutRg As Range On Error Resume Next Application.Volatile Set xRg = Application.Intersect(Rg, Rg.Worksheet.UsedRange) If Not (xRg Is Nothing) Then For Each xCell In xRg If (xCell.EntireRow.Hidden = False) And _ (xCell.EntireColumn.Hidden = False) Then If xOutRg Is Nothing Then Set xOutRg = xCell Else Set xOutRg = Application.Union(xCell, xOutRg) End If End If Next End If If Not xOutRg Is Nothing Then SumVisible = Application.Evaluate("SUM(" & xOutRg.Address & ")") Else SumVisible = 0 End If End Function د يجمع سواء الصفوف أو الأعمده الظاهرة في النطاق المراد جمعه ولكن الكود يعمل تلقائي مع الصفوف وبخصوص الأعمدة يجب تحديث الخلية التي ستضع فيها الصيغة الناشئة من الكود وهي =sible(Range) هذا والله أعلم

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb