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

تفضل التعديل Function CalcAge(StartDate As Date, EndDate As Date) As String Dim years As Integer Dim months As Integer Dim days As Integer Dim totalMonths As Integer totalMonths = Int(DateDiff("m", StartDate, EndDate)) + _ (EndDate < DateSerial(Year(EndDate), Month(EndDate), Day(StartDate))) years = Int(totalMonths / 12) months = totalMonths Mod 12 ' تحويل 30 يومًا إلى 01 شهر If days = 30 Then months = months + 1 days = 0 End If CalcAge = years & " سنة و " & months & " شهر و " & days & " يوم" End Function

مشاركة مع استاذ @Moosak تفضل أخي محاولتي بمرفقك بعد التعديل . Database.rar

ابشر ، بتم التعديل وبرفق الملف

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

اشكر حضرتك على عملك الرائع جزاك الله خيرا كثيرا

معادلة أولى لأقل من صفر =COUNTIF($A$2:$A$19;"<"&0%) معادلة ثانية بين صفر وخمسين =COUNTIFS($A$2:$A$19;"<="&50%;$A$2:$A$19;">="&0%) معادلة ثالثة أكثر من 50 وأقل من 101 =COUNTIFS($A$2:$A$19;"<"&101%;$A$2:$A$19;">"&50%) مع رجاء الانتباه إلى استخدام الفاصلة أو الفاصلة المنقوطة حسب نظام الحاسب لديك

جزاك الله خير

وعليكم السلام تفضل أخي الكريم Book2.xlsx

بارك الله فيك وأكثر الله من أمثالك وربنا يزيدك من علمه

Public Sub CopyData2() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") ' خلية البداية Col_Star = 10 '(R) عمود الشرط Col_Search = 18 'الشرط الاول(الفصل) Clé1 = desWS.[R12] 'الشرط الثاني (المادة) Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False 'التحقق من وجود قيمة في خلايا الشرط If Len(Clé1) > 0 And Len(Clé2) > 0 Then ' افراغ البيانات السابقة desWS.Range("C14:U" & Rows.Count).ClearContents ' اسماء الاوراق المستهدفة Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSdata = Sheets(Sh(i)) With WSdata ' الغاء الفلترة .AutoFilterMode = False ' Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' النطاق Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow ' في حالة تحقق الشرط الاول If WSdata.Cells(Rng, Col_Search).Value = Clé1 Then 'عمود (C) تحديد اخر صف عليه بيانات rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row ' الاعمدة المرغوب جلب بياناتها Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) ' لصق البيانات بعد اخر قيمة من عمود (C) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSdata.Cells(Rng, Cpt(c)).Value Next c End If Next Rng ' فلترة جميع الاوراق على الشرط الاول rngFound.AutoFilter Field:=16, Criteria1:=Clé1 ' البحث في الصف 9 عن الشرط الثاني (المادة) Set rngSearch = WSdata.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then 'نسخ بيانات العمود rngSearch.Offset(1).Resize(ligne - 1).Copy ' لصق بعد اخر خلية من عمود (U) desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'الغاء الفلترة rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub

تفضل تم تحقيق المطلوب لا اعلم ما العمليات التي ستجريها على النموذج والشجرة .. لذا اكتفيت بالمطلوب مع جعل اتجاه الشجرة الى اليمين TreeUp.rar

وعليكم السلام ورحمة الله تعالى وبركاته Public Sub CopyData() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") Col_Star = 10: Col_Search = 18: Clé1 = desWS.[R12]: Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False If Len(Clé1) > 0 And Len(Clé2) > 0 Then desWS.Range("C14:U" & Rows.Count).ClearContents Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSData = Sheets(Sh(i)) With WSData .AutoFilterMode = False Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow If WSData.Cells(Rng, Col_Search).Value = Clé1 Then rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSData.Cells(Rng, Cpt(c)).Value Next c End If Next Rng rngFound.AutoFilter Field:=16, Criteria1:=Clé1 Set rngSearch = WSData.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then rngSearch.Offset(1).Resize(ligne - 1).Copy desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub ترحيل الدرجات v2.xlsm

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) اليوم جئتكم بفكرة جديدة وأعتقد أنه لم يسبقني أحد بهذا الطريق ؛ وهو إضافة اختيار واجهة اللغة إلى تطبيقات وبرامج ومشاريع الآكسيس بطريقة جديدة وتقدروا تقولوا 2024 في البداية سأقوم بشرح المطلوب داخل القاعدة التي سيتم التطبيق عليها ، أولاً :- جدول واحد فقط يحتوي على حقل واحد فقط أيضاً وسنسميه بـ SettingsTable ، والحقل الذي بداخله هو Language من نوع نصي ( Text ) . ثانياً :- نموذج Settings وهو طبعاً ليس له مصدر سجلات . وبداخله كومبوبوكس Combo box سيكون اسمه cboLanguage نوع مصدر بياناته Value List ؛ ومصدر بياناته القيم التالية ( "العربية";"English" ) . ثالثاً :- بجانب قاعدة البيانات سنقوم بإنشاء مجلد جديد وسيتم تسميته بـ Language . الآن خطوات العمل :- الموديول Module :- قم بإنشاء Module جديد وسمه بـ Set_Language ؛ وهو مفتاح العمل والذي من خلاله سنعتمد على جلب الترجمة من الملفات التي سنقوم بإنشائها لاحقاً . وهذا الكود مع الشرح الكامل له بين السطور . Option Compare Database Option Explicit ' المتغير العام لتخزين اللغة الحالية Public CurrentLanguage As String ' تحديث اللغة الحالية Public Sub UpdateLanguage() On Error Resume Next ' احصل على اللغة المحددة من جدول الإعدادات CurrentLanguage = DLookup("Language", "SettingsTable") ' قم بتحديث العلامات في جميع النماذج UpdateLabelsInAllForms End Sub ' تحديث العلامات في جميع النماذج Private Sub UpdateLabelsInAllForms() Dim frm As AccessObject ' تحديث العلامات في جميع النماذج المحملة For Each frm In CurrentProject.AllForms If frm.IsLoaded Then UpdateLabelsInForm Forms(frm.Name) End If Next frm End Sub ' تحديث العلامات في نموذج محدد Private Sub UpdateLabelsInForm(frm As Object) Dim arFile As String, enFile As String Dim arLabels() As String, enLabels() As String Dim i As Integer ' احصل على ملف اللغة العربية واللغة الإنجليزية arFile = GetLanguageFilePath("Arabic.txt") enFile = GetLanguageFilePath("English.txt") ' اقرأ الملفات واملأ المصفوفات بالنصوص المترجمة arLabels = Split(ReadFile(arFile), vbCrLf, -1) enLabels = Split(ReadFile(enFile), vbCrLf, -1) ' قم بتحديث العلامات في النموذج For i = 0 To UBound(arLabels) UpdateLabel frm, "Label" & CStr(i + 1), arLabels(i), enLabels(i) UpdateLabel frm, "Command" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub ' احصل على مسار قاعدة البيانات الحالية Private Function GetDatabasePath() As String Dim dbPath As String dbPath = CurrentDb.Name GetDatabasePath = Left(dbPath, InStrRev(dbPath, "\")) End Function ' احصل على مسار ملف اللغة Private Function GetLanguageFilePath(fileName As String) As String GetLanguageFilePath = GetDatabasePath() & "Language\" & fileName End Function ' اقرأ ملف النص وارجع النص كنص نصي Private Function ReadFile(filePath As String) As String Dim fileNumber As Integer fileNumber = FreeFile Open filePath For Input As fileNumber ReadFile = Input$(LOF(fileNumber), fileNumber) Close fileNumber End Function ' تحديث علامة محددة في النموذج بناءً على اللغة الحالية Private Sub UpdateLabel(frm As Object, labelName As String, arabicText As String, englishText As String) On Error Resume Next ' قم بتحديث العلامة بناءً على اللغة الحالية frm.Controls(labelName).Caption = IIf(CurrentLanguage = "العربية", arabicText, englishText) On Error GoTo 0 End Sub * ملاحظة :- سنعتمد هنا على طريق بسيط جداً وهو المسميات في النماذج ، فمثلاً لو انشأنا زر في نموذج ما وكانت تسميته Caption هي حفظ وكان اسم الزر Command1 ؛ فعند الترجمة سيصبح كل زر في البرنامج باسم Command1 هو بمثابة زر الحفظ وستكون ترجمته Save ؛ لذا سنعتمد طريقة توحيد المسميات في النماذج وهذا سيجعل الأمر سهلاً جداً للصيانة ، وطبعاً لا يمكن أن يكون لعنصرين ( كائنين ) في النموذج لهما نفس الإسم . رابعاً :- العودة إلى نموذج Settings الذي تم التحدث عنه في النقطة ( ثانياً ) ؛ سنقوم بدايةً باستكمال إنشاء الأكواد الخاصة بتغيير اللغة ، قبل الأحداث للـ Combo Box والنموذج . سنقوم بإدراج هذه الأكواد الثلاثة البسيطة :- ' تحديث العناصر في النموذج بناءً على اللغة المختارة Private Sub UpdateLanguageForControls() On Error Resume Next Dim ctrl As AccessObject For Each ctrl In Me.Controls ' يمكنك هنا إضافة العناصر الأخرى التي تريد تحديثها بناءً على اللغة ' مثلا: If TypeOf ctrl Is ComboBox Then Next ctrl End Sub ' حفظ اختيار اللغة في جدول SettingsTable Private Sub SaveLanguageChoice() CurrentDb.Execute "UPDATE SettingsTable SET Language='" & Me.cboLanguage & "'" End Sub ' تغيير اللغة وتحديث العناصر ذات الصلة Private Sub ChangeLanguage(selectedLanguage As String) CurrentDb.Execute "UPDATE SettingsTable SET Language='" & selectedLanguage & "'" UpdateLanguageForControls End Sub وفي حدث عند الفتح للنموذج سنقوم بإدراج هذا الكود :- ' حدث يتم تنفيذه عند فتح النموذج Private Sub Form_Open(Cancel As Integer) UpdateLanguage End Sub وفي حدث عند التحديث للكومبوبوكس سندرج الكود التالي :- ' حدث يتم تنفيذه بعد تحديث اختيار اللغة من ComboBox Private Sub cboLanguage_AfterUpdate() Dim response As VbMsgBoxResult Dim Language As String ' احصل على اللغة المحددة من ComboBox Language = Me.cboLanguage.Value ' قم بتحديد الرسالة بناءً على اللغة المختارة If Language = "العربية" Then response = MsgBox("هل ترغب في تغيير اللغة إلى العربية؟", vbQuestion + vbYesNo, "التأكيد") ElseIf Language = "English" Then response = MsgBox("Do you want to change the language to English?", vbQuestion + vbYesNo, "Confirmation") End If ' قم باتخاذ الإجراء المناسب بناءً على رد المستخدم If response = vbYes Then SaveLanguageChoice Application.Quit Else SaveLanguageChoice DoCmd.Close End If End Sub الآن نأتي لأهم نقطة في هذا الموضوع ، ألا وهي . أين ستكون الترجمة ؟ طبعاً قمنا سابقاً بإنشاء المجلد Language بجانب قاعدة البيانات ، الآن سنذهب إليه وسنقوم بإنشاء ملفين نصيين Text الأول Arabic.txt ، والثاني English.txt . في الأعلى افترضنا انه لدينا في النموذج زر اسمه Command1 والـ Caption له كانت حفظ ، الآن سنقوم بكتابة المسمى بالعربي وهو حفظ في ملف النص Arabic ، وفي الملف الثاني English سنكتب Save وهو أول أمر قمنا به كتجربة ( لاحظ أن Command يتبعها الرقم 1 ) وعليه فأن أي مسمى Command1 في أي نموذج سيكون اسمه حفظ أو Save عند اختيار الإنجليزية . وفي النهاية سأترك مرفق يحتوي تطبيق لما تحدثنا به سابقاً . والمتابعة لأي استفسار أو توضيح Change Language.zip

السلام عليكم ورحمة الله وبركاته في ملاحظة جانبية سأتطرق إليها للتوضيح في نقطة قد يتساءل البعض عنها في هذا الجزء For i = 0 To UBound(arLabels) UpdateLabel frm, "Label" & CStr(i + 1), arLabels(i), enLabels(i) UpdateLabel frm, "Command" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub تمت إضافة هذا الجزء من الكود ليشمل الـ Lable كما في الجزء الأول ، والـ Command في الجزء الثاني. حيث أن المسميات ستكون متبوعة برقم وهو الذي سيحدد رقم السطر في ملفات اللغة ( Arabic , English ) ، فهنا نستطيع التوحيد في مسميات البرنامج ( كتوحيد المقامات في الرياضيات 😅 ) طبعاً هنا سنحتاج جزء واحد من السطر ، ولنفترض أن الكود سيصبح بهذا الشكل:- For i = 0 To UBound(arLabels) UpdateLabel frm, "Officna" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub هنا قمت بتوحيد جميع العناصر والكائنات في المشروع ( مربعات نص ، ليبلات ، ازرار ..... إلخ ) تحت اسم Officna وهنا يسهل علينا - وكما ذكر معلمنا الفاضل @ابوخليل - حفظ المسميات وسهولة الوصول إليها وتحديدها .. ودمتم بخير 🤗

في إحدى التجارب لي على ما تم طرحه في الموضوع ، قمت بتجربة لتجربة سابقة لي في التعامل مع ملفات الـ Dll الوهمية ( الملفات المُعاد تسمية لاحقتها 😅 ) . فمثلاً بعد تطبيق المسميات للعناصر باللغتين ( العربية ، الإنجليزية ) داخل ملفات Arabic.txt و English.txt قمت بتغيير لاحقة الملفين من txt إلى dll وحتى من داخل الأكواد في المديول في هذين السطرين :- ليصبحا بهذا التغيير :- GetLanguageFilePath("Arabic.dll") enFile = GetLanguageFilePath("English.dll") وقد كانت التجربة ناجحة 😀 بأن تم قراءة ترجمة المكونات المستهدفة لهذه الوظيفة . قد تكون الفكرة لغير المهتمين غير مجدية ؛ إلا أنها فكرة لحماية الملفات مؤقتا من أيدي العابثين 😅. إلا أنني وددت مشاركتكم أصوات ( بنات أفكاري ) . ودمتم بخير 🤗

عمل راااائع ما شاء الله تبارك الرحمن أخي @Foksh عندي سؤال : لماذا لم تحفظ الترجمة في جدول بالبرنامج بدل حفظها في ملفات خارجية ؟ 🙂 ثانيا : أضفت لمسة للبرنامج وهي أنه يقوم بإعادة تشغيل البرنامج تلقائيا بعد اختيار اللغة المطلوبة 🙂 وذلك باستخدام هذا الكود : Sub RestartAccess() Dim vbsFilePath As String vbsFilePath = CurrentProject.Path & "\Restart.vbs" ' Change the file path as needed Dim vbsContent As String vbsContent = "WScript.Sleep(2000)" & vbCrLf & _ "CreateObject(""Shell.Application"").Namespace(0).ParseName(""" & CurrentProject.FullName & """).InvokeVerb ""Open""" ' Create the VBS file and write the content Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim vbsFile As Object Set vbsFile = fso.CreateTextFile(vbsFilePath, True, False) vbsFile.Write vbsContent vbsFile.Close ' Shell execute the VBS file to restart Access Shell "wscript.exe """ & vbsFilePath & """", vbNormalFocus ' Exit Access Application.Quit End Sub Change Language.zip

اخي ابوعلي الملف اكسيل 2010 بالمرفقات لكن التكست بوكس الخاص برقم العائلة اغلقت الادخال به بناء علي الملاحظة التي وضعتها (يترك رقم العائلة فارغ) فلذلك قمت بتأمينه علي اية حال تم التعديل تقبل تحياتي استمارة معلومات العائلة الالكتروني.rar