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

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

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

تباارك الله ، ما شااء الله ، عمل جميل وجهود رائعة منكم معلمنا الفاضل @ابوخليل و أستاذنا الحبيب @kkhalifa1960 . جزاكم الله خيرا على هذا الطرح المتكامل 🥰

أستاذنا ومعلمنا @ابوخليل نظل وسنظل نتعلم ونغتنم منكم الخبرة في الترتيب واستخدام الأكواد المناسبة حين الحاجة فقط و.......................................................... سلمت يداك .

رائع جدا وينفع ان يكون انطلاقة لعمل اشمل بحيث يعدل ليكون متوافق مع لائحة ادارة الوظيفي والتي تعتمد مبدأ تقييم الموظف وفقا لما حققه من الأهداف والجدارات والوزن النسبي والناتج المستهدف لكل هدف وجدارة وفق ميثاق الأداء والذي يتم توقيعة مع الموظف في بداية دورة الاداء

وعليكم السلام ورحمة الله تعالى وبركاته لاظافة صور جديدة او استبدالها يجب عليك اتباع الخطوات التالية 1) اظهار الصور المخفية بواسطة الكود المرفق مع الملف 2) اعادة تسمية الصور على حسب احتياجاتك وقد تم شرح الطريقة في الرابط التالي https://streamable.com/ghw7yy اما بخصوص اخر سؤال المعادلة الموجودة في الخلية F3 =IF(D3="";"";VLOOKUP(D3;range1;3;0)) تقوم فقط بجلب اسم الصورة من شيت 2 العمود D المقابلة لقيمة الخلية D3 ورقة 1 ليس بتحويل الصورة الى نص وفي حدث ورقة 1 الكود التالي يقوم باخفاء جميع الصور والبقاء على الصورة الهدف بشرط قيمة الخلية F3 Private Sub Worksheet_Calculate() Dim oPic As Picture Me.Pictures.Visible = False With Range("F3") For Each oPic In Me.Pictures If oPic.Name = .Text Then oPic.Visible = True oPic.Top = .Top oPic.Left = .Left Exit For End If Next oPic End With End Sub البيانات مع الصورة 2.xls

السلام عليكم 🙂 اذا عندنا تقرير بهذه الطريقة: . اليس الافضل دمج بيانات الحقل المتكررة عموديا في حقل واحد ، مثل الوورد مثلا الى : . طريقة العمل : 1. اعمل تقريرك بالطريقة اللي تراها مناسبة ، بالفرز والتصفية : . او بالمجاميع : . 2. ولكن قم بوضع جميع الحقول في قسم "التفصيل" Detail : . 3. ثم اجعل برواز جميع حقول هذا القسم شفافة . 4. ثم الحقول التي تريد دمجها ، اخفاء المتكرر = نعم ، Hide Duplicates = Yes . 5. ثم ضع هذه الاحداث للتقرير Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) 'Border color not set, use field ForeColor Call Detail_Print_Run_All(5, "'اليوم', 'التاريخ','الزمن'") End Sub Private Sub Report_Open(Cancel As Integer) Call Report_Open_Run(Me.Name) End Sub Private Sub Report_Close() On Error Resume Next Set ctl_ReSize = Nothing End Sub Private Sub Report_Page() Call Report_Page_Run End Sub . 6. لا تحتاج الى عمل اي تغيير في الاحداث اعلاه ، فقط انسخها من هنا والصقها في تقريرك ، ما عدا اول جزء : عرض البرواز ، حيث نخبره باسماء الحقل/الحقول التي نريد دمجها عموديا ، لون البرواز يكون حسب اللون الذي نكتبه ، او اذا لم نكتب لون البرواز ، فلون البرواز سيكون لون نص الكلمات في الحقل . 7. نسخ الوحدة النمطية mod_Report_Field_Hieght_ReSize الى تقريرك ن وكذلك بدون عمل اي تغيير فيها : Option Compare Database Option Explicit Dim rpt_Name_ReSize As String Dim rgb_Border_ReSize As Long, ini_rgb_Border_ReSize As Long Dim Detail_Calc_Height_ReSize As Long Dim Exclude_fld_Name_ReSize As String Dim Add_H_Each_Record_ReSize As Boolean Dim fildMaxHeight_ReSize As Long Dim myDrawWidth As Integer Public ctl_ReSize As Control Dim i_ReSize As Integer, j_ReSize As Integer Dim x_ReSize() As String, tmp_ReSize As String Dim Count_Pages_ReSize As Integer Dim sfld_Name_ReSize() As String, sfld_Value_ReSize() As String, _ sfld_Count_ReSize() As Integer Dim L_ReSize As Single, T_ReSize As Single, W_ReSize As Single, H_ReSize As Single ' Function Detail_Print_Run_All(LineWidth As Integer, myFields As String, Optional border_Color As Long = 1) 'we can this Function in the following ways, indicating Border Color 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", RGB(0, 0, 0)) 'Border color is RGB Value 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", vbBlack) 'Border color is Black 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'", vbMagenta) 'Border color is Magenta 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'") 'Border color not set, use field ForeColor 'Call Detail_Print_Run_All(5,"'b1'", RGB(0, 0, 0)) '5 is Line Width 'we get most the Lines drawn in Detail Section, 'except for the Last Record in each page, where we use Report Page event (the last page is easy) ini_rgb_Border_ReSize = border_Color rgb_Border_ReSize = ini_rgb_Border_ReSize Exclude_fld_Name_ReSize = myFields Add_H_Each_Record_ReSize = False myDrawWidth = LineWidth 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") ReDim Preserve sfld_Name_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Value_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Count_ReSize(UBound(x_ReSize)) '1 'do the Detail Lines for the remaining fields Call Detail_Sec_Max_Height '2 'now work on the special fields Lines For i_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(i_ReSize), "'", ""))) sfld_Name_ReSize(i_ReSize) = tmp_ReSize Call Scale_Box_Lines(tmp_ReSize) Next i_ReSize End Function Function Report_Open_Run(rpt_Name_ReSize_1) rpt_Name_ReSize = rpt_Name_ReSize_1 'Reset the variables from here Count_Pages_ReSize = 0 Erase sfld_Name_ReSize Erase sfld_Value_ReSize Erase sfld_Count_ReSize Detail_Calc_Height_ReSize = 0 End Function Function Report_Page_Run() 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") 'now work on the special fields Lines For j_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(j_ReSize), "'", ""))) sfld_Name_ReSize(j_ReSize) = tmp_ReSize Set ctl_ReSize = Reports(rpt_Name_ReSize)(tmp_ReSize) If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top 'H_ReSize = ctl_ReSize.Height 'we have to add the Sections/Fields ABOVE the Detail Section If Reports(rpt_Name_ReSize).Page = 1 Then H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height + _ Reports(rpt_Name_ReSize).ReportHeader.Height Else H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height End If Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize + H_ReSize)-(L_ReSize + W_ReSize, T_ReSize + H_ReSize), rgb_Border_ReSize 'Bottom Line Next j_ReSize Detail_Calc_Height_ReSize = 0 End Function Public Function Scale_Box_Lines(fld_Name As String) Set ctl_ReSize = Reports(rpt_Name_ReSize)(fld_Name) 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top H_ReSize = ctl_ReSize.Height If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'take the highst Height If fildMaxHeight_ReSize > H_ReSize Then H_ReSize = fildMaxHeight_ReSize End If If ctl_ReSize.Text <> sfld_Value_ReSize(i_ReSize) Then sfld_Value_ReSize(i_ReSize) = ctl_ReSize.Text sfld_Count_ReSize(i_ReSize) = 1 End If 'Box the cells 'Left and Right ctl_ReSize.BorderColor = vbWhite Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize, H_ReSize), rgb_Border_ReSize 'Left Line Reports(rpt_Name_ReSize).Line (L_ReSize + W_ReSize, T_ReSize)-(L_ReSize + W_ReSize, H_ReSize), rgb_Border_ReSize 'Right Line 'Top and Bottom If Reports(rpt_Name_ReSize).Page <> Count_Pages_ReSize Then 'first Count_Pages_ReSize = Count_Pages_ReSize + 1 Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line ElseIf sfld_Count_ReSize(i_ReSize) = 1 Then 'First Record Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line End If sfld_Count_ReSize(i_ReSize) = sfld_Count_ReSize(i_ReSize) + 1 End Function Public Function Detail_Sec_Max_Height() fildMaxHeight_ReSize = 0 'get the max Height For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If ctl_ReSize.Height > fildMaxHeight_ReSize Then fildMaxHeight_ReSize = ctl_ReSize.Height End If Next 'Draw lines around the fields For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If InStr(Exclude_fld_Name_ReSize, "'" & ctl_ReSize.Name & "'") = 0 Then Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (ctl_ReSize.Left, ctl_ReSize.Top)-Step(ctl_ReSize.Width, fildMaxHeight_ReSize), ctl_ReSize.ForeColor, B 'just add the Heighs of ONE Record If Add_H_Each_Record_ReSize = False Then Detail_Calc_Height_ReSize = Detail_Calc_Height_ReSize + fildMaxHeight_ReSize Add_H_Each_Record_ReSize = True End If End If Next End Function . 8. ما عدا هذا الجزء ، والذي يجب ان نضع فيه اسماء جميع الاقسام التي فوق "قسم التفصيل" ، والتي بها ارتفاع : . من هنا نعرف اسم هذه الاقسام : . وهذه نتائج بعض التقارير التي تم النجربة عليها : . . . . ولم اتوصل لطريقة لجعل الكلمات في منتصف الحقل عموديا ، هكذا: جعفر Report_BoxLine_07.accdb.zip

InStr(1, ..., "TYA") تستخدم للبحث عن تواجد السلسلة "TYA" في القيمة المحولة إلى أحرف كبيرة. إذا كانت "TYA" موجودة في النص، ستكون قيمة الدالة غير صفرية، وإذا لم تكن موجودة، ستكون القيمة صفر ارسل مرفق ، او افتح موضوع جديد ان كان على غير صلة بهذا الموضوع 😊

Private Sub manner_BeforeUpdate(Cancel As Integer) ' التحقق مما إذا كانت القيمة المدخلة تحتوي على أحد الرموز المطلوبة If InStr(1, UCase(Me.manner.Value), "TYA") = 0 And InStr(1, UCase(Me.manner.Value), "LKA") = 0 Then ' عرض رسالة تحذيرية للمستخدم MsgBox "يرجى عدم نسيان كتابة الرمز Tya أو Lka", vbExclamation, "تحذير" ' إلغاء التحديث ليظل المستخدم في نفس الحقل Cancel = True End If End Sub في هذا الكود، تم استخدام UCase لتحويل النص إلى أحرف كبيرة للتحقق بغض النظر عن حالة الحروف. والتحقق من وجود "TYA" أو "LKA" في القيمة المدخلة. إذا لم يتم العثور على أي من هذين الرمزين، سيتم عرض رسالة تحذيرية وإلغاء التحديث ليظل المستخدم في نفس الحقل

لك كل لتقدير والاحترام معلمنا Foksh

هل الرمز هذا شرط أن يكون في مربع النص manner ؟ جرب هذا الكود في حدث قبل التحديث Private Sub manner_BeforeUpdate(Cancel As Integer) ' التحقق مما إذا كانت القيمة المدخلة تحتوي على الرمز المطلوب If InStr(Me.manner.Value, "tya") = 0 Then ' عرض رسالة تحذيرية للمستخدم MsgBox "يرجى عدم نسيان كتابة الرمز tya", vbExclamation, "تحذير" ' إلغاء التحديث ليظل المستخدم في نفس الحقل Cancel = True End If End Sub

لك جزيل الشكر معلمنا الكريم Foksh بعد شرحك وصلت للمعلومة الصحيحة

والله اخ @Foksh لو اقولك اخونا @kkhalifa1960 ساعدني ازاي ومعرفتش اوفيه حقه في صبره معايا جزاه الله وجزاك كل خير

كل العذر منك أخي @سامر محمود ، ولكن صدقني لو قلتلك بسبب العمل من بعد منتصف الشهر الماضي للآن ومضغوطين بجولة سنة وتجديد بعض الأمور . لكن تبارك الله الأساتذة وبجهود أستاذنا @kkhalifa1960 أفادوا أفضل مني 😊. ولنا في القريب نشاركات ، ما تخاف 😅

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

اختنا الكريمة safaa salem5 بالغ التقدير والتحية اخى الفاضل ومعلمنا kkhalifa1960 لك جزيل الشكر اخى الفاضل واستاذنا Foksh لك جزيل الشكر

تفضل أخي @jo_2010 🙂 هذا شكل الكود في الموديول : Public Sub PrintOut(pname As String, ID As Long) Screen.ActiveForm.Refresh If MsgBox("هل ... تريد طباعة التقرير الخاص بــ " & pname & " ؟ ", vbQuestion + vbMsgBoxRight + vbYesNo, Default_Title) = vbYes Then DoCmd.OpenReport "ss", acViewPreview, , "[id]=" & ID DoCmd.PrintOut DoCmd.Close acReport Else DoCmd.OpenReport "ss", acViewPreview, , "[id]=" & ID End If End Sub وتستدعيه بهذه الطريقة لأنه صار يستقبل معاملين هذه المرة ( الــ ID ، واسم الموظف ) Call PrintOut(pname.Value, Me.ID) Code.accdb

مشاركة مع الأستاذ @kkhalifa1960 ، وإن كنت قد فهمت المطلوب بشكل صحيح إليك هذه الفكرة . أولا سنقوم بإنشاء جدول بشكل تلقائي ؛ وسيكون اسمه Tbl_Rep كمثال . ثانياً سنقوم بإدراج نتيجة الفلترة والتي تمت حسب ما يلي :- التاريخ من - إلى اسم الصنف - داخل هذا الجدول مع العلم أن الجدول هو مصدر التقرير Bayan . ثالثاً سنقوم بعرض التقرير بناءً على السجلات التي تم اختيارها . وأخيراً المرفق bayan _ prin.accdb

امين لنا ولكم اخي يونس والله يقضي بهبات وافرة .. لي ولكم في درجات الآخرة الاخ الشايب

الاستاذين الفاضلين / شايب و kkhalifa1960 تم حل جميع المعضلات . جزاكم الله عنا خير الجزاء وجعل ذلك في ميزان حسناتكم .

اجعل الترقيم في حدث بعد التحديث لحقل الاسم وليس القيمة الافتراضية للحقل ترقيم يومي.accdb

غير سلوك مفتاح الادخال الى افتراضي

اعرض الملف FACTURIER EXPRESS PRO 2024 - SQLite DataBase FACTURIER EXPLRESS PRO APP.EXCEL SQLite ....COMMENT APPLIQUER UNE APPLICATION GESTION COMMERCIALE EXCEL VBA SQLite صاحب الملف محمد أبوصهيب تمت الاضافه 08 ينا, 2024 الاقسام قسم الإكسيل  

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

جرب هذا الكود: بعد تشغيله أول مرة خذ لك نظرة على الفاتورة، ثم شغله مرة ثانية للتخلص من السطور الفارغة. Option Explicit Sub Macro1() Dim row1 As Integer, row2 As Integer, col As Integer Dim lRow As Integer, tRow As Integer On Error Resume Next Sheets("الفواتير").Select lRow = Range("A1").SpecialCells(xlLastCell).row Range("A2:I" & lRow).Select ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Add Key:=Range("الفواتير[رقم الفاتورة]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Add Key:=Range("الفواتير[الصنف]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With tRow = 3 For row1 = 3 To lRow If Cells(row1, 4) <> "" Then tRow = row1 For row2 = row1 + 1 To lRow If Cells(row2, 4) = Cells(tRow, 4) And _ Cells(row2, 8) = Cells(tRow, 8) Then Cells(tRow, 5) = Cells(tRow, 5) + Cells(row2, 5) For col = 1 To 9 Cells(row2, col) = "" Next col Else Exit For End If Next row2 End If Next row1 Range("A3").Select MsgBox "Done" End Sub تم إضافة هذا السطر: On Error Resume Next تم التعديل في هذ السطر: For row1 = 3 To lRow وإضافة هذين السطرين أيضا: Else Exit For

بالنسبة 1،2 يعمل بشكل طبيعي أما 3 الفورم في وضع التصميم وحدد كل المكونات ثم كليك يمين وسوي كما بالشرح بالفيديو .

تفضل أخي @Abdelaziz Osman محاولتي . ووافني بالرد . bayan _ prin.rar

تفضل أخي @سامر محمود المرفق بعد الإنتهاء من تكوينه من وجهة نظري . وعليك قراءته جيداً والتجريب . وموافاتي بأي إضافات تريدها . Evaluation_Employees.rar

السلام عليكم أستاذ محمد بارك الله بجهودكم وزادكم علماً نافعاً ...آمين

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

وعليكم السلام تفضل: Book1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصد Sub test() Dim i As Long, lRow As Long lRow = Cells(Rows.Count, "A").End(xlUp).Row With Application .ScreenUpdating = False For i = lRow To 2 Step -1 If IsError(.Match(0, Range("A" & i & ":D" & i), 0)) Then Rows(i).EntireRow.Delete End If Next .ScreenUpdating = True End With End Sub ملف.xlsb

الحمد لله ولك الشكر في حدث الصفحة (Sheet code) يوجد ماكرو يعمل فقط عند تغير الرقم(Sheet code)

ملاحظة : في حالة قمت بحدف عناوين الاعمدة سيتم نسخ البانات بعد اخر خلية فارغة في عمود C ولتثبيت اللصق في الصف 22 ما عليك هو تعديل الصفوف التالية 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)) If dest.[C22] = Empty Then dest.[C22].Resize(1, 28).Value = Rng.Value Else: dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value End If End If ''''''''''''''''''''''''''''''او'''''''''''''''''''''''''''' Dim dlr As Long For j = 22 To ligne If UCase(WS.Cells(j, col)) = r Then dlr = dest.Cells(Rows.Count, "C").End(xlUp).Row If dlr < 21 Then dlr = 21 Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30)) dest.Range("C" & dlr).Offset(1).Resize(1, 28).Value = Rng.Value End If Next j

وعليكم السلام ورحمة الله تعالى وبركاته 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

لتصميم الشاشة الرئيسية وسهولة التحكم فىيها تم اضافة جدول جديد باسم 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

السلام عليكم الاخوة الافاضل عبارات الشكر لا تفى حقكم لأنكم أكبر منها، فأنتم لكم الفضل في تحويل الفشل إلى نجاح، ورفع العزيمة والمعنوية لدي، فأنتم أهل التميز استاذنا الفاضل وجيه شرف الدين الف الف شكر لحضرتك على مجهودكم الكود يعمل و ينفذ المطلوب باحترافيه عالية استاذنا الفاضل الخلوق محمد هشام. بارك الله فى عمرك و الف الف شكر على تعبك الكود رائعه و ينفذ المطلوب و كما عودنا لا تبخل بجهدك ربنا يحفظك و يبارك فى حضرتك و اسرتك الكريمة استاذنا الفاضل

تفضل اخي Option Explicit Sub FILTRE() ' فلترة البيانات بين تاريخين واسم القسم Dim i&, R, LastRow As Long, rngCell, c As Range Dim a(1 To 3) a(1) = [BK1]: a(2) = [BK2]: a(3) = [BP1] Dim MyRng As Range Dim WSdata As Worksheet: Set WSdata = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False WSdata.Range("BJ5:BY1000").ClearContents Set MyRng = WSdata.Range("AM2:BD" & WSdata.Cells(WSdata.Rows.Count, "am").End(xlUp).Row) R = MyRng For i = 1 To UBound(R) If R(i, 17) >= a(1) And R(i, 17) <= a(2) And R(i, 18) = a(3) Then WSdata.Range("BJ" & Rows.Count).End(xlUp).Offset(1).Resize(1, 16).Value _ = Array((R(i, 1)), (R(i, 2)), (R(i, 3)), (R(i, 4)), (R(i, 5)), (R(i, 6)), (R(i, 7)), (R(i, 8)), (R(i, 9)), (R(i, 10)), (R(i, 11)), (R(i, 12)), (R(i, 13)), (R(i, 14)), (R(i, 15)), (R(i, 16))) End If Next ' تسطير البيانات LastRow = WSdata.Range("BJ:BY").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSdata.Range("BJ5 :BY" & LastRow) WSdata.Range("BJ5:BY1000").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSdata.Range("BJ5:BY5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If Application.ScreenUpdating = True End Sub اظافات ممكن تفيدك للاشتغال على الملف بشكل افضل Sub CreateValidation() 'انشاء قوائم التاريخ والقسم تلقائيا بدون تكرار Dim J, K, lr As Long Dim a(1 To 2) As String Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1") lr = WSdata.Range("BC:BD").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row J = WSdata.Range("BC2:BC" & lr): K = WSdata.Range("BD2:BD" & lr) J = column(Application.Transpose(J)): a(1) = Join(J, ",") K = column(Application.Transpose(K)): a(2) = Join(K, ",") With WSdata.Range("BK1:BK2").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(1) End With With WSdata.Range("BP1").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(2) End With End Sub Function column(arr) As Variant With Application column = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _ UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False)) End With End Function وفي حدث ورقة1 انسخ الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) ' تحديث القوائم عند الاظافة او التعديل في عمود التاريخ او القسم On Error Resume Next lr = Range("BC" & Rows.Count).End(xlUp).Row If Not Intersect(Target, Range("BC2:BC" & lr)) Is Nothing Then Application.EnableEvents = False Call CreateValidation Application.EnableEvents = True Exit Sub End If ' تنفيد الكود عند التغيير في خلية القسم If Not Intersect(Target, Target.Worksheet.Range("BP1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call FILTRE Application.EnableEvents = True End If On Error GoTo 0 End Sub استخراج بالتاريخ 2.xlsm