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

السلام عليكم ورحمه الله وبركاته اضع بين ايديكم هديه متواضعه صدقه جاريه على روح والدى ( برجاء قراءه الفاتحه ) الانتهاء من برنامج اداره وتوزيع النوبتجيات والاجازات ينفع لكافه الانشطه المدنيه العسكريه التى تعتمد على نوبتجيات او ورديات - متابعه الاجازات بدقه ( يحسبلك المتبقي من العرضيات والسنويات وما الي ذلك ) ورفض تسجيلها فى حاله كون الموظف نوبتجي - توزيع النوبتجيات اتوماتيك لكل القوه حسب النوبتجيه المكلف بها ( استثناء الاجازات من التوزيع ودرجهم فالدور بمجرد انتهاء الاجازات ) - عرض تقارير مفصله ( سواء اجازات - نوبتجيات لكل موظف ) - حجم البرنامج لا يتعدي ١٠ ميجا ويعمل علي كافه انظمه اوفيس بدايه من اوفيس ٢٠١٠ - يضع التقارير والنوبتجيات تلقائي في مجلدات بجانب البرنامج ( تقارير شهريه - نوبتجيات موظفبن - اجازات موظفين - نوبتجيات يوميه ) - يصلح لكافه الاغراض المدنيه التي تعمل علي ورديات مختلفه أو توزيع عماله علي اماكن عمل ومواقع مختلفه ( سواء شركات أمن - شركات نظافه - خدمات بتروليه - مصانع ...الخ ) -😎😎 البرنامج مجاني بكل اكواده وتصميماته ومتاح للتعديل صدقه جاريه على روح والدى الله يرحمه فضلا وليس امرا الدعاء له كلمه المرور 1510 ملحوظه تم الاستعانه بتصميم بعض قواعد البيانات ( تصاميم فقط ) لكن كل اكواد البرنامج هي من تصميمي إن شاءالله نوبتجيات.rar

اسف نست ارفع المرفق نوبتجيات V. 2.zip

خد راحتك يا كبير

مبسوط كده يا عم @Foksh الباسورد : 1510 علشان متزعلش بس وعلشان فرحتك تتم كلمة المرور تظهر وتختفى زى الحلاوة والقايمة بتختفى يا عم وبردو مافيهاش ترميش ومن الكلام ده على الله بس تكون مبسوط معلش بئه يا @M.Abd Allah عدلت حبة حجات ثغننه ع السريع كده بس علشان @Foksh أفندى ينبسط

قصدك 1510 ده

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub addbtn_Click() Dim n As Long Dim src As Worksheet: Set src = Sheets("Data") n = Application.WorksheetFunction.CountA(src.Range("B:B")) + 1 If Me.studname = "" Then: Exit Sub src.Cells(n, 2) = Me.cod.Value src.Cells(n, 3) = Me.studname.Value src.Cells(n, 4) = Me.row.Value src.Cells(n, 5) = Me.class.Value src.Cells(n, 6) = Me.group.Value src.Cells(n, 7) = Me.studcase.Value src.Cells(n, 8) = Me.birthdate.Value src.Cells(n, 9) = Me.mother.Value src.Cells(n, 10) = Me.gender.Value src.Cells(n, 11) = Me.mobile.Value src.Cells(n, 12) = Me.subcase.Value src.Cells(n, 13) = Me.adress.Value src.Cells(n, 14) = Me.datenow.Value src.Cells(n, 15) = Me.employ.Value src.Cells(n, 16) = Me.notes.Value With src.Range("A2:A" & src.Cells(src.Rows.Count, "B").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")") End With arr = Array("studname", "cod", "row", "birthdate", "class", "studcase", "mobile", _ "notes", "group", "mother", "gender", "subcase", "adress") For i = 0 To UBound(arr): Me.Controls(arr(i)).Value = Empty: Next i MsgBox "تمت عملية التسجيل بنجاح" 'ActiveWorkbook.Save End Sub دوبل كليك على الصف الاول من ورقة Data لاظهار اليوزرفورم Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect(Target, Range("A1:P1")) Is Nothing Then Cancel = True ADD.Show End If End Sub school data 2025x V2.xlsm

وانت عمال تقوله خد راحتك 😂 اتفضل ،، اهو نسي يرفع الملف من الفرحة 😂😂😁 قال ينبسط قال ، يا حبيبي انا لما اشوف اسمع ببقى عامل زي العصفور اللي طاير من الفرحة 🤣

متوافق ولكن المشكلة لديك في المكتبات جرب استبدل Dim db As DAO.Database بـــ Dim db As Database

اخي @ابو جودي تحية طيبة جزاك الله كل خير ولكن التقريب يتم مع الارقام الموجبة فقط اما الارقام السالبة يتم التقريب بشكل خاطئ تم الوصول للحل و الحمدلله و الشكر للجميع Public Function MyRound(ByVal MainVal As Double, ByVal RoundVal As Double) As Double Dim Oldrnd As Double, X2 As Double, Newrnd As Double, Var1 As Double On Error GoTo ErrSub Var1 = RoundVal \ 2 X2 = Application.WorksheetFunction.RoundDown(MainVal / RoundVal, 0) Newrnd = X2 * RoundVal Oldrnd = MainVal - Newrnd Select Case Oldrnd Case Is >= 0 Select Case Oldrnd Case Is >= Var1 MyRound = Newrnd + RoundVal Case Is < Var1 MyRound = Newrnd End Select Case Is < 0 Var1 = Var1 * -1 Select Case Oldrnd Case Is <= Var1 MyRound = Newrnd - RoundVal Case Is > Var1 MyRound = Newrnd End Select End Select ErrSub: If Err.number <> 0 Then 'MsgBox Err.number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight MyRound = 0 Exit Function End If End Function

شكرا استاذ @M.Abd Allah ❤️🌹🌹 حاشني الوسواس 😁 استاذي @ابو جودي ❤️🌹🌹❤️ يعدل بقيت اعدلك ضبط العشوائي لا يتكرر حتى الي بعده مع تسجيل اكثر احترافية تصميم بيعقد مع صلاحيات واضافة اسم الحاسوب على القليل 3 قواعد اضافية 😗☕ اشلون نخلي النص المتحرك ينزل من اعلى الى الاسفل بشريط التحكم ================= اربع عناصر مجموعة تراكمي = ربط تراكمي (حزمة العناصر بوضع التصميم ) كود : dim rung as integer for rung = 1 to 4 if rung =1 then me.text1.hight = 100 me.text2.hight = 0 me.text3.hight = 0 me.text4.hight = 0 end if if rung =2 then me.text2.hight = 100 me.text1.hight = 0 me.text3.hight = 0 me.text4.hight = 0 end if if rung =3 then me.text3.hight = 100 me.text2.hight = 0 me.text1.hight = 0 me.text4.hight = 0 end if if rung =4 then me.text4.hight = 100 me.text2.hight = 0 me.text3.hight = 0 me.text1.hight = 0 end if Next 'call rung_Click جرب 😇

لا يصح الا الصحيح وبعدين هو اصلا مبيقولكش عالجروب برضو غير كده 🤣🤣 انا ريحتكم مني فتره فالجروب وهنا اعتقد كده مبسوطين من غيري

هههههههه بعد ما ذكره ولا قبل !!!!! نروح الشهر العقاري واتنازل لك فيه , بس انت حدد يوم

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

هو مش كنت مستعجل تقريبا يعنى ع الاقل رد تقول الدنيا تمام واللا لاء

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

مشكورين على الردود@ ولكن موقع اوفسينا بعتلي مسج على ايميل الياهو اللي نسيت الباسورد بتاعه ومشكورين https://www.officena.net/ib/profile/21181-ayman-z-harb/ هذا ايميلي السابق في اوفسينا

على فكره دا فورم الدخول بتاعى😊

شكرا لك على هذا العطاء بروف @M.Abd Allah 🙂 🌹🌷🌼

You can use helper column as you can't directly use SUBTOTAL with COUNTIF but you can achieve that using SUMPRODUCT approach Suppose you have names in range B2:B6 and you want to count if the name starts with [Kh] letters Now you can try this formula =SUMPRODUCT(SUBTOTAL(103, OFFSET(B2:B6, ROW(B2:B6)-MIN(ROW(B2:B6)), 0, 1)) * EXACT(LEFT(B2:B6, 2), "Kh"))

مين يارب .. ربنا يستجيب دعواتكم ويحقق أمنياتنا وأمنياتكم

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

طيب جربى الكود بالشكل ده وبعد التجربة فولى لى فى رسائل خطأ ظهرت معاكى واللا لاء Sub UpdateFields() On Error GoTo ErrorHandler OpenFormAndSetFields "PT_frm" Dim ptRValue As Variant Dim ptLValue As Variant Dim ptHValue As Variant Dim conc_rValue As Variant Dim INR_rValue As Variant Dim ratio_rValue As Variant Dim reference_value As Variant Dim gender As String Dim ageunit As String Dim normalType As String Dim age As Integer gender = Forms!pt_frm!gender age = Forms!pt_frm!age ageunit = Forms!pt_frm!ageunit normalType = DLookup("normal_type", "test_tbl", "tcode = 144") If normalType = "sex" Then If gender = "female" Then ptRValue = DLookup("rfemale", "test_tbl", "normal_type = 'sex' AND tcode = 144") ptLValue = DLookup("lfemale", "test_tbl", "normal_type = 'sex' AND tcode = 144") ptHValue = DLookup("hfemale", "test_tbl", "normal_type = 'sex' AND tcode = 144") conc_rValue = DLookup("rfemale", "test_tbl", "normal_type = 'sex' AND tcode = 145") INR_rValue = DLookup("rfemale", "test_tbl", "normal_type = 'sex' AND tcode = 146") ratio_rValue = DLookup("rfemale", "test_tbl", "normal_type = 'sex' AND tcode = 147") ElseIf gender = "male" Then ptRValue = DLookup("rmale", "test_tbl", "normal_type = 'sex' AND tcode = 144") ptLValue = DLookup("lmale", "test_tbl", "normal_type = 'sex' AND tcode = 144") ptHValue = DLookup("hmale", "test_tbl", "normal_type = 'sex' AND tcode = 144") conc_rValue = DLookup("rmale", "test_tbl", "normal_type = 'sex' AND tcode = 145") INR_rValue = DLookup("rmale", "test_tbl", "normal_type = 'sex' AND tcode = 146") ratio_rValue = DLookup("rmale", "test_tbl", "normal_type = 'sex' AND tcode = 147") End If ElseIf normalType = "sex and age" Then reference_value = DLookup("Reference", "normals_tbl", _ "Gender = '" & Forms("pt_frm")("gender").Value & "' AND " & _ "Ageunit = '" & Forms("pt_frm")("ageunit").Value & "' AND " & _ "tcode = 144 AND " & _ Forms("pt_frm")("age").Value & " BETWEEN [from] AND [to]") If Not IsNull(reference_value) Then Forms("pt_frm")("pt_r").Value = reference_value Else MsgBox "لم يتم العثور على قيمة مرجعية للشروط المحددة.", vbExclamation End If End If Forms!pt_frm!pt_r.Value = ptRValue Forms!pt_frm!pt_h.Value = ptHValue Forms!pt_frm!pt_l.Value = ptLValue Forms!pt_frm!conc_r.Value = conc_rValue Forms!pt_frm!inr_r.Value = INR_rValue Forms!pt_frm!ratio_r.Value = ratio_rValue Forms!pt_frm!pt_u.Value = DLookup("unit", "test_tbl", "normal_type = '" & normalType & "' AND tcode = 144") Forms!pt_frm!Control.Value = DLookup("default", "test_tbl", "normal_type = '" & normalType & "' AND tcode = 148") Forms!pt_frm!conc_u.Value = DLookup("unit", "test_tbl", "normal_type = '" & normalType & "' AND tcode = 145") Forms!pt_frm!inr_u.Value = DLookup("unit", "test_tbl", "normal_type = '" & normalType & "' AND tcode = 146") Forms!pt_frm!ratio_u.Value = DLookup("unit", "test_tbl", "normal_type = '" & normalType & "' AND tcode = 147") Exit Sub ErrorHandler: MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical End Sub

جميل جدا وشغل على العالى انا منتظر المرفق لكى اطبقه

بارك الله فيك أخي الغالي ابو يوسف @محمد حسن المحمد لو المشكله في الاميل يمكنه كتابه الاميل القديم له وان شاء الله سوف نجد حلا لمشكله الاخ السائل @ايمن حرب

أظن أن نظام القائمة أسهل!!!! هل تقصد أنك ترغب بكتابة الإسم وجلب البيانات باستخدام زر البحث؟ جرب هذا ReDim a(1 To UBound(r), 1 To UBound(r, 2)) For I = 1 To UBound(r) If r(I, 5) = clé Then F = F + 1 a(F, 1) = r(I, 2):a(F, 2) = r(I, 4): a(F, 3) = r(I, 6) a(F, 4) = r(I, 7):a(F, 5) = r(I, 3):a(F, 6) = r(I, 1) End If Next I Search_by_name-V2.xlsm

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

وعليكم السلام ورحمة الله وبركاته ما معني تصكر هل اتقفل ام تم حذفه ؟؟ لو ملف اكسيل يمكن رفعه هنا

تفضل جرب هدا ملاحظة لم يتم تحديد العمود الاخير لعدم معرفتي لاسم العمود المرغوب جلب بياناته لهدا سبق تدكيرك بارفاق عينة للنتائج المتوقعة Sub Search_by_name() Dim WS As Worksheet, src As Worksheet Dim r As Variant, a As Variant, Rng As Range Dim i As Long, F As Long, Lastrow As Long Dim clé As Variant, Search As Range Set WS = Worksheets("AA"): Set src = Worksheets("UU") Lastrow = WS.Columns("B:I").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = WS.Range("B2:I" & WS.Cells(Rows.Count, "F").End(xlUp).Row) r = Rng.Value2: clé = src.[C1] If clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "الامل الدولية": Exit Sub Set Search = WS.Range("F2:F" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " غير موجود", vbExclamation: Exit Sub Application.ScreenUpdating = False src.Range("B3:G" & src.Rows.Count).ClearContents ReDim a(1 To UBound(r), 1 To UBound(r, 2)) For i = 1 To UBound(r) If r(i, 5) = clé Then F = F + 1 a(F, 1) = r(i, 2) a(F, 2) = r(i, 4) a(F, 3) = r(i, 6) a(F, 4) = r(i, 7) a(F, 5) = r(i, 3) ' رقم اليوزر ' a(F, ؟) = r(i, ؟) End If Next i src.[B2].Offset(1).Resize(F, UBound(a, 2)).Value2 = a Application.ScreenUpdating = True End Sub وفي حدث ورقة (UU) Private Sub Worksheet_Activate() ' جلب الاسماء بدون تكرار Set WS = Worksheets("AA") Application.ScreenUpdating = False Set MonDico = CreateObject("Scripting.Dictionary") For Each cnt In WS.Range("f2", WS.[f65000].End(xlUp)) If cnt <> "" Then MonDico(cnt.Value) = "" Next cnt With WS.Range("L2:L65000") .ClearContents .Resize(MonDico.Count) = Application.Transpose(MonDico.Keys) End With Application.ScreenUpdating = True End Sub '===================== Private Sub Worksheet_Change(ByVal Target As Range) ' تنفيد الكود عند اختيار الاسم من القائمة المنسدلة Select Case Target.Address(0, 0) Case "C1": Call Search_by_name Target.Select Case Else: Exit Sub End Select End Sub الخلية C1 ورقة (UU) ضع الصيغة التالية =OFFSET(AA!$L$2, 0, 0, COUNTA(AA!$L:$L), 1) بالتوفيق......... Search_by_name.xlsm

اخي ما هو العمود المرغوب ترحيله الى رقم اليوزر

لايمكن الاشتغال على صورة المرجوا ارفاق ملفك مع عينة للنتائج المتوقعة

يمكنك وضع الكود التالي في Private Sub Workbook_Open Private Sub Workbook_Open() ' هنا اسماء الاجهزة المسموح للمصنف الاشتغال عليها If Environ("computername") <> "CFAMURAD" And Environ("computername") <> "Officena" Then 'عند عدم تحقق الشرط يتم اظهار الرسالة وغلق الملف Application.DisplayAlerts = False MsgBox " لا يمكنك تشغيل هدا المصنف على هدا الكمبيوتر " & _ vbLf & vbLf & " .......... المرجوا الاتصال", _ vbOKOnly + vbExclamation + vbDefaultButton1 + vbApplicationModal, "معلومات" ThisWorkbook.Close Application.DisplayAlerts = True End If End Sub يستحسن وضع باسوورد لمحرر الاكواد لكي لا يتم التلاعب بالملف فتح المصنف على اجهزة محددة.rar

للأسف لم يعمل !