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

العفو اخي @Moosak لقد استفدت منكم الكثير وقد طلعت بنتيجة أخرى سوف أشرحها إن شاء الله عما قريب .

وعليكم السلام ورحمة الله وبركاته ان شاء الله يكون هذا المطلوب Book1 (4).xlsx

منكم تعلمنا الجمال اخي @Foksh بارك الله فيك

عمل جميل أستاذ @Barna

احسنت استاذنا الغالي برناوي @Barna الشفرة جميلة جدا ..عاشت الايادي

طيب جرب على حالات اخرى .... Dim db As DAO.Database Dim rs As DAO.Recordset Dim i, TT As Integer Dim numCopies As Integer Set db = CurrentDb Set rs = db.OpenRecordset("SELECT tp2.GradeNO, tp2.سنوات_المكوث FROM tp2 WHERE (((tp2.GradeNO)<=" & Me.الدرجة_الوظيفية & ")) ORDER BY tp2.GradeNO DESC;", dbOpenDynaset) TT = iYear Do Until rs.EOF TT = TT - rs!سنوات_المكوث numCopies = rs!سنوات_المكوث If TT < rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية + TT rs.MoveNext GoTo RR 'Exit Sub End If For i = 1 To numCopies Next i rs.MoveNext Loop RR: If Me.مربع_تحرير_وسرد49 > rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = 1 Exit Sub End If rs.Close Set rs = Nothing Set db = Nothing

نتمنى لك التوفيق أخي حسان .. 🙂🌷 ولو صبرت علي قليلا .. سأقوم بعون الله بإنزال التحديثات الأخيرة حول هذا الموضوع مع الملفات كاملة 🙂👌

رائع جدا ... طريقة ممتازة جزاك الله خيرا أخي Foksh

ومشاركتي البسيطة هنا يتم فيها فتح النموذج واخفاء الزر واغلاقه مرة أخرى بدون اي أخطاء 222.accdb

السلام عليكم 🙂 الكود صحيح .. المشكلة فقط هي أن النموذج الثاني يجب أن يكون مفتوح ليعمل الكود .. هنا أضفت لك سطر للتحقق من أن النموذج الثاني مفتوح قبل تطبيق الكود .. ولو كان مغلق يفتحه ' للتحقق من أن النموذج الثاني مفتوح قبل تطبيق الكود If CurrentProject.AllForms("frm2").IsLoaded = False Then DoCmd.OpenForm "frm2" If Me.on = True Then Forms!frm2.btn.Visible = True Else Forms!frm2.btn.Visible = False End If

من هنـــــــــــــــــــــــا مع ملاحظة أن بعض جمل الاس كيو ال لا تظهر سليمة فى الاكسبلورر ، لذا يرجي نسخها اذا أردنا تنفيذها أو مشاهدتها فى المثال المرفق Q3.zip

تسلم ايدك يا @Foksh استاذ ورئيس قسم ربنا يزيدك علم

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

السلام عليكم تفضل الكود كامل مع البرنامج الله يبارك فيك تحياتي Dim db As DAO.Database Dim rs As DAO.Recordset Dim i, TT As Integer Dim numCopies As Integer Set db = CurrentDb Set rs = db.OpenRecordset("SELECT tp2.GradeNO, tp2.سنوات_المكوث FROM tp2 WHERE (((tp2.GradeNO)<=" & Me.الدرجة_الوظيفية & ")) ORDER BY tp2.GradeNO DESC;", dbOpenDynaset) TT = iYear Do Until rs.EOF TT = TT - rs!سنوات_المكوث numCopies = rs!سنوات_المكوث If TT < rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية + TT rs.MoveNext GoTo RR 'Exit Sub End If For i = 1 To numCopies Next i rs.MoveNext Loop RR: If Me.مربع_تحرير_وسرد49 > rs!سنوات_المكوث Then Me.مربع_تحرير_وسرد47 = rs!GradeNO - 1 Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية - 1 Exit Sub End If rs.Close Set rs = Nothing Set db = Nothing final.mdb

السلام عليكم ممكن تشوف الملف كدة يمكن يساعدك ListEleve_20240320.rar

السلام عليكم استاذي العزيز @Barna شكرا لك بارك الله فيك اصبح البرنامج شغال 100% بعد تعديل كود واحد فقط الى: Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية - 1 تحياتي

حياك الله بشمهندس @Eng.Qassim تقبل الله منا ومنكم صالح الاعمال جزاك الله خير

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

حسب ما فهمت ، تريد الكود في زر الحفظ ؟؟ مع تطبيق الشروط الحالية عليه ؛ صحيح ؟ تفضل ، وأخبرني بالنتيجة Arciving222.zip

تم التعديل على طريقة تنفيذ الكود ليكون الكود كاملاً في زر الحفظ .. مع الذهاب الى سجل جديد عند فتح النموذج Arciving222.zip

تفضل أخي الكريم ، استبدل الكود في حدث بعد التحديث بالتالي :- Private Sub مربع_تحرير_وسرد137_AfterUpdate() On Error Resume Next Dim strFilter As String Dim strName As String strName = Replace(Replace(Replace(Replace(Me.مربع_تحرير_وسرد137, "أ", "ا"), "إ", "ا"), "ة", "ه"), "ه", "ه") If Len(strName) > 0 Then strFilter = "Replace(Replace(Replace(Replace([jname], 'أ', 'ا'), 'إ', 'ا'), 'ة', 'ه'), 'ه', 'ه') LIKE '*" & strName & "*'" End If With Me.sub_ورقة1.Form If Len(strFilter) > 0 Then .Filter = strFilter .FilterOn = True Else .Filter = "" .FilterOn = False End If .Requery End With End Sub جربه وأخبرني بالنتيجة Waheidi2005_2.zip

أعتذر عن التأخير أخي سامر ، بالنسبة للطلب الأول ( عدد المكررات في الرسالة ) تفضل :- استبدل الحدث في النموذج قبل التحديث من الماكرو إلى هذا الكود Private Sub Form_BeforeUpdate(Cancel As Integer) Dim count As Integer count = DCount("[ID_Number]", "[Ekhla_Details]", "[ID_Number]='" & Forms("Ekhla_Details").Controls("IDNumber").Value & "'") If count >= 1 Then Dim response As VbMsgBoxResult response = MsgBox("أن هذا الموظف له إخلاء سابق عدد " & count & " ، هل تريد الاستمرار ؟ ", vbYesNo) If response = vbYes Then Else Me.Undo MsgBox "تم إلغاء السجل", , "" End If Else MsgBox "تم إلغاء السجل", , "" Me.Undo End If End Sub Arciving222.zip

الاخفاء غير جيد كمنظر لترتيب الازرار والافضل وجوده مع عدم التفعيل عند الفتح تضع احد هذين السطرين ، ويبقى كودك اللي عملته اعلاه تحصيل حاصل Me.btn_e.Enabled = False 'لعدم التفعيل Me.btn_e.Visible = False 'للإخفاء في التقارير قد لا تتعرف على الاعلان العام عن المتغير فقط .. لذا يمكننا صنع وظيفة تاخذ القيمة وادراجها في التقرير funGuserName FinancialPrg6.rar

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

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

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

وعليكم السلام ورحمة الله تعالى وبركاته Dim F, Rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) Rng = F.Value Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) For i = LBound(Rng) To UBound(Rng): Rng(i, 5) = Format(Rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Array(5, 4, 3, 2, 1): j = UBound(Total) + 1 d("*") = "" For i = 1 To UBound(Rng) d(Rng(i, 4)) = "" Next i r = d.keys Me.T1.List = r: Me.T1 = "*" MySum End Sub '********************* Private Sub T1_click() Dim Tbl(): n = 0: Clé = Val(Me.T1) For i = 1 To UBound(Rng) If Rng(i, 4) >= Clé Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = Rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub V2 تجربة.xlsm

جميل جدا جدا جدا جدا تسلم ايدك

هو ينفع ليه لأ .. بس أوصل البيت هحاول أتفاهم مع جهازي 😅 أصله واخد على خاطره حبتين اليومين دول 😁

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

الموقع الأول الموقع الثاني الموقع الثالث لتأثيرات النصوص ( عربي - English )

لا أعلم لم تقوم بارسال قاعدة البيانات كاملةً .. على العموم جرب انشاء استعلام جديد وضع كود الـ SQL التالي به ، واجعله مصدر بيانات للتقرير كتجربة SELECT members.fileno, members.nome, members.gov, members.tel1, parents.mmob, parents.fmob, [telholder] & "," & [tholdrelation] & "," & [telno] AS [All] FROM (members INNER JOIN parents ON members.[fileno] = parents.[fileno]) INNER JOIN tels ON (parents.fileno = tels.fileno) AND (members.fileno = tels.fileno) GROUP BY members.fileno, members.nome, members.gov, members.tel1, parents.mmob, parents.fmob, [telholder] & "," & [tholdrelation] & "," & [telno] HAVING (((members.fileno)<10)); وأخبرني بالنتيجة 😅

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

تفضل حل اخر لاثراء الموضوع Sub Filter_month2() Dim Cpt As Long, rgFound As Range Dim cel As Range, Rng As Range, Clé As Range Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2") lastRow = WS.Range("B" & Rows.Count).End(xlUp).Row Set Clé = desWS.Range("L2") Set Rng = WS.Range("B3:B" & lastRow) For Each cel In Rng If Month(cel) = Month(Clé) Then Set rgFound = cel Exit For End If Next cel If rgFound Is Nothing Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(Clé), vbOKOnly + vbExclamation, "admin" Exit Sub End If desWS.Range("B5:M" & Rows.Count).ClearContents For Col = 3 To lastRow If IsDate(WS.Range("B" & Col).Value) = True Then If Month(WS.Range("B" & Col).Value) = Month(Clé) Then Cpt = desWS.Range("b" & Rows.Count).End(xlUp).Row + 1 desWS.Range("B" & Cpt & ":M" & Cpt).Value = WS.Range("A" & Col & ":L" & Col).Value End If End If Next Application.ScreenUpdating = True End Sub

ادن اخي يجب التحقق اولا من تنسيق خلية اسم الشهر .اليك الملف عليه الكود يمكنك تطويعه بما يناسبك Sub Filter_month() Dim lr&, i&, j&, c& Dim arr As Variant, K As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2") lastrow = desWS.Range("b" & Rows.Count).End(xlUp).Row clé = desWS.[L2] If clé = 0 Then MsgBox "المرجوا تحديد شهر الفلترة", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = WS.Range("B" & Rows.Count).End(xlUp).Row On Error Resume Next arr = WS.Range("A3:L" & lr).Value ReDim K(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) If Month(arr(i, 2)) = Month(clé) Then desWS.Range("B5:M" & Rows.Count).ClearContents For c = LBound(arr, 2) To UBound(arr, 2) K(j, c) = arr(i, c) Next c j = j + 1 End If Next i desWS.Range("b5").Resize(j - 1, UBound(K, 2)).Value = K If Err <> 0 Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(clé), vbExclamation, "admin" End Sub Filter_month.xlsb