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

ضبط التلاعب بتاريخ الكمبيوتر الشرح بالفيديو التالي . Manipulating computer Date settings.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

شكرا استاذ على التعديل الصحيح الان استاذي العزيز القيم المالية 3000 و 1500 قهي ربما تكون غير ثابتة مستقبلا فكيف يتم جلبها من الجدول بدلا من كتابتها في MsgBox تقليدي message = "عزيزي المنخرط(ة)، يمكنك الاستفادة من " & menhaType & ": " & menhaName & Etar & " حتى تاريخ 30/06 للعام الحالي لأنك سددت 3000 للعام السابق و1500 لشهر مارس للعام الحالي." صح لسانك استاذي الاكسوارات على صاحب البرنامج فعلا ولكن ياريت تجربة لهذه الدالة vbMsgBoxRight على الاقل حتى لميساج واحد وا لباقي اكمله بنفسي وشكرا لكم

كلامك سليم ...... الاكسسوارات والتنسيقات على صاحب البرنامج استاذي @Foksh جرب المرفق وكل الاحتمالات التي لديك ............. BAR_AِِِA_20250320.mdb

انتم احد اهم ركائز المنتدى واحد اعظم الاساتذة الذين يتعلم منهم كل طلاب العلم وانا أول هؤلاء الطلاب وفى مقدمتهم ولا نظن بكم الا كل الخيــــــر

إنفجار بعد الإفطار فى كتابة الأكواد .. نصيحة خد لك ساتر شكراً أبو جودي على كل إبداعاتك لكن لى ملاحظة عن قانون 2019 بعيدة عن الأكواد عندما تبحث فى جوجل عن "جدول خروج الموظفين على المعاش" تجد الكثير جداً من هذا الجدول والقليل _ يكاد لا يذكر _ من هذه الصورة والسؤال لذوى الإختصاص : أيهما الصحيح 1 / 1 أم 1 / 7

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

وعليكم السلام ورحمة الله تعالى وبركاته للتنفيد على المصنف الخارجي معاهد ورقة معهد Public Property Get f() As Worksheet: Set f = ThisWorkbook.Sheets("test"): End Property Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "معاهد.xlsm" wsName = "معهد" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property Sub Split_Rows() Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long, TotalSum As Double Dim k As Integer, Irow As Integer, r As Long, count As Long, tbl As Double, j As Double Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub k = f.Range("G1").Value If k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow j = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + j If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = j + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = j + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = j + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop Irow = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(Irow + 1).Insert Shift:=xlDown With .Cells(Irow + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & Irow + 1 & ":E" & Irow + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With If Not CrWS Is Nothing Then Call PrintArea_data(CrWS) End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub '============================================ Sub déleteRows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim LastRow As Long, i As Long If CrWS Is Nothing Then: MsgBox "لم يتم العثور على المصنف أو الورقة المحددة", vbExclamation: Exit Sub Application.ScreenUpdating = False With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i End With Application.ScreenUpdating = True End Sub '==================================== Sub PrintArea_data(CrWS As Worksheet) Dim rCount As Long, tmps As Long, i As Long Dim lastCol As Long, OnRng As Range, n As Long n = f.Range("G1").Value + 2 If n <= 0 Then Exit Sub tmps = 2 CrWS.ResetAllPageBreaks rCount = CrWS.Cells(CrWS.Rows.count, 2).End(xlUp).Row If rCount > tmps + n Then For i = tmps + n To rCount Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(1, "E").Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, 1), CrWS.Cells(rCount, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) With CrWS.PageSetup .Orientation = xlPortrait .PaperSize = xlPaperA4 .FitToPagesWide = 1 .FitToPagesTall = False End With End Sub وللتنفيد على نفس المصنف ورقة test Public Property Get CrWS() As Worksheet: Set CrWS = Sheets("test"): End Property Sub Split_Rows() Const SumRng As String = "المجموع" Const ColArr As String = "المدور" Const SumPages As String = "المجموع الكلي للصفحات" Dim xColor As Long: xColor = RGB(204, 255, 204) Dim LastRow As Long, i As Long, StartRow As Long, EndRow As Long Dim k As Integer, j As Integer, r As Long, count As Long Dim tbl As Double, TotalSum As Double, Irow As Double k = CrWS.Range("G1").Value If CrWS.Name <> "test" Or k <= 0 Then MsgBox "G1:" & "يرجى تحديد عدد الصفوف المطلوبة في الخلية", vbInformation: Exit Sub With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With CrWS .ResetAllPageBreaks LastRow = .Cells(.Rows.count, "B").End(xlUp).Row For i = LastRow To 2 Step -1 If .Cells(i, "B").Value = SumRng Or _ .Cells(i, "B").Value = ColArr Or _ .Cells(i, "B").Value = SumPages Or .Cells(i, "B").Value = "" Then .Range("A" & i & ":E" & i).Interior.ColorIndex = xlNone .Range("A" & i & ":E" & i).Delete End If Next i LastRow = .Cells(.Rows.count, "A").End(xlUp).Row StartRow = 2 tbl = 0 TotalSum = 0 i = StartRow Do While i <= LastRow EndRow = i + k - 1 If EndRow > LastRow Then EndRow = LastRow Irow = Application.WorksheetFunction.Sum(.Range("E" & i & ":E" & EndRow)) TotalSum = TotalSum + Irow If EndRow < LastRow Then .Rows(EndRow + 1).Insert Shift:=xlDown .Cells(EndRow + 1, "B").Value = SumRng .Cells(EndRow + 1, "E").Value = Irow + tbl .Range("A" & EndRow + 1 & ":E" & EndRow + 1).Interior.Color = xColor .Rows(EndRow + 2).Insert Shift:=xlDown .Cells(EndRow + 2, "B").Value = ColArr .Cells(EndRow + 2, "E").Value = Irow + tbl .Range("A" & EndRow + 2 & ":E" & EndRow + 2).Interior.Color = xColor tbl = Irow + tbl LastRow = LastRow + 2 End If i = EndRow + 3 Loop j = .Cells(.Rows.count, "A").End(xlUp).Row .Rows(j + 1).Insert Shift:=xlDown With .Cells(j + 1, "B") .Value = SumPages .Offset(0, 3).Value = TotalSum .Resize(1, 4).Font.Size = 18 .Parent.Range("A" & j + 1 & ":E" & j + 1).Interior.Color = xColor End With .Range("A2:A" & .Cells(.Rows.count, "B").End(xlUp).Row).ClearContents For r = 2 To .Cells(.Rows.count, "B").End(xlUp).Row If .Cells(r, 2).Value <> SumRng And .Cells(r, 2).Value <> ColArr And _ .Cells(r, 2).Value <> SumPages Then .Cells(r, 1).Value = count + 1 count = count + 1 End If Next r End With Call PrintArea_data .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub للتنفيد على مصنف خارجي.rar تحديد عدد صفوف للصفحة ومجموعها v2.xlsm

بل أنا من يسعده ذلك بل واتشوق الى ذلك فكما تعلم أنت ملهمى ودائما تكمل ما ينقص أفكارى

لا حاجة للإعتذار ، وانما يسعدني مشاركتك الأفكار ..

طيب اولا شكرا على افكارك يا استاذ فؤش افندى وسعيد جدا جدا جدا بمشاركة حضرتك ثانيا اعتذر ان المشاركة أتت بعدك ولكن انا تقريبا بدأت كتابة المشاركة وتعديل الكود بالتطويرات الجديده تقريبا من الساعه 11: 45 تقريبا ولو لاحظت هتلاقينى ذكرت فى المشاركة فطبعا اعتذر ان جائت المشاركة بعد مشاركتك دون الاشارة اليكم فيها انت وضعت المشاركه وانا منشغل فى التنسيق وتطوير الكود وتعديل المشاركة اثناء تطوير الكود والرد والمشاركة فى نفس الوقت على موضع أخر فى المنتدى فى نفس الوقت وطبعا لو اردنا النتائج فى مرفقى المتواضع تظهر بشكل مباشر مع تغيير السجلات يمكن فقط ان يكون الكود التالى فى حدث الحالى للنموذج Private Sub Form_Current() Call btnCalculateGetInfo_Click End Sub حتى ولو كان مصدر بيانات النموذج هو الجدول مباشرة دون الاعتماد على الاستعلام كما قدمته انا كما فى هذا المرفق الاخيــــــــــــــــــــــر * ملاحظة انا عدلت الكود لتمرير اسم مربع النص كعنصر تحكم فى هذا المرفق بدلا من تمريره كنص سلسلة نصية تمت التوصيه من وجهة نظرى المتواضعة بهذا الكود النهائى فى هذا المرفق الشامل والوافى الاكواد النهائية بعد التطوير فى الوحده النمطية لحساب سن التقاعد Option Compare Database Option Explicit '------------------------------------------------------------ ' وحدة لحساب سن التقاعد والوقت المتبقي حتى التقاعد ' تحتوي على دالتين رئيسيتين: ' 1. GetRetirementInfo: لحساب تفاصيل التقاعد وإرجاعها كسلسلة نصية ' 2. PopulateRetirementFields: لتوزيع النتائج على مربعات نصوص في نموذج '------------------------------------------------------------ ' دالة لحساب تفاصيل التقاعد بناءً على تاريخ الميلاد ' الغرض: تحديد سن التقاعد، تاريخ التقاعد، والوقت المتبقي (سنوات، أشهر، أيام) ' المعاملات: ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - showDetails (Boolean, اختياري): إذا كان True، يتم إرجاع التفاصيل الكاملة، وإذا كان False يتم إرجاع تاريخ التقاعد فقط ' الإرجاع: سلسلة نصية تحتوي على نتائج الحسابات أو رسالة خطأ إذا كان المدخل غير صالح Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer ' متغير لتخزين سن التقاعد Dim RetirementDate As Date ' متغير لتخزين تاريخ التقاعد Dim remainingYears As Integer ' متغير لتخزين السنوات المتبقية حتى التقاعد Dim remainingMonths As Integer ' متغير لتخزين الأشهر المتبقية حتى التقاعد Dim remainingDays As Integer ' متغير لتخزين الأيام المتبقية حتى التقاعد Dim result As String ' متغير لتخزين النتيجة النهائية كسلسلة نصية Dim currentDate As Date ' متغير لتخزين التاريخ الحالي Dim tempDate As Date ' متغير مؤقت للمساعدة في الحسابات التدريجية ' التحقق من صحة تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "" ' إرجاع رسالة خطأ إذا كان التاريخ فارغًا أو غير صالح Else birthDate = CDate(birthDate) ' تحويل المدخل إلى تاريخ ' تحديد سن التقاعد بناءً على تاريخ الميلاد وفقًا للقواعد المحددة If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد بإضافة سن التقاعد إلى تاريخ الميلاد RetirementDate = DateAdd("yyyy", retirementAge, birthDate) ' إذا تم طلب التفاصيل الكاملة If showDetails Then currentDate = Date ' تعيين التاريخ الحالي ' حساب السنوات المتبقية باستخدام الفرق بين التاريخ الحالي وتاريخ التقاعد remainingYears = DateDiff("yyyy", currentDate, RetirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) ' تصحيح السنوات إذا تجاوز التاريخ المؤقت تاريخ التقاعد If tempDate > RetirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If ' حساب الأشهر المتبقية تدريجيًا remainingMonths = 0 While DateAdd("m", 1, tempDate) <= RetirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام المتبقية باستخدام الفرق بين التاريخ المؤقت وتاريخ التقاعد remainingDays = DateDiff("d", tempDate, RetirementDate) ' تجميع النتيجة كسلسلة نصية تحتوي على جميع التفاصيل result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & RetirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else ' إرجاع تاريخ التقاعد فقط إذا لم يتم طلب التفاصيل result = "تاريخ التقاعد: " & RetirementDate End If End If GetRetirementInfo = result ' إرجاع النتيجة النهائية End Function ' إجراء لتوزيع تفاصيل التقاعد على مربعات نصوص في نموذج ' الغرض: أخذ نتائج GetRetirementInfo وتعيينها في مربعات نصوص منفصلة أو مربع نص واحد ' المعاملات: ' - frm (Form): النموذج الذي يحتوي على مربعات النصوص ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - txtBirthDate, txtRetirementAge, txtRetirementDate, txtRemainingYears, ' txtRemainingMonths, txtRemainingDays (TextBox, اختياري): كائنات مربعات النصوص للقيم المنفصلة ' - txtAllDetails (TextBox, اختياري): كائن مربع النص لعرض السلسلة الكاملة Public Sub PopulateRetirementFields(frm As Form, birthDate As Variant, _ Optional txtBirthDate As TextBox, Optional txtRetirementAge As TextBox, _ Optional txtRetirementDate As TextBox, Optional txtRemainingYears As TextBox, _ Optional txtRemainingMonths As TextBox, Optional txtRemainingDays As TextBox, _ Optional txtAllDetails As TextBox) Dim result As String ' متغير لتخزين النتيجة من GetRetirementInfo Dim lines() As String ' مصفوفة لتقسيم السلسلة إلى أسطر Dim i As Integer ' متغير للحلقة ' تفريغ جميع مربعات النصوص الممررة أولاً On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If Not txtAllDetails Is Nothing Then txtAllDetails.Value = "" If Not txtBirthDate Is Nothing Then txtBirthDate.Value = "" If Not txtRetirementAge Is Nothing Then txtRetirementAge.Value = "" If Not txtRetirementDate Is Nothing Then txtRetirementDate.Value = "" If Not txtRemainingYears Is Nothing Then txtRemainingYears.Value = "" If Not txtRemainingMonths Is Nothing Then txtRemainingMonths.Value = "" If Not txtRemainingDays Is Nothing Then txtRemainingDays.Value = "" On Error GoTo 0 ' التحقق من تاريخ الميلاد ومعالجته فقط إذا كان صالحًا If Not IsNull(birthDate) And IsDate(birthDate) Then ' استدعاء دالة GetRetirementInfo مع طلب التفاصيل الكاملة result = GetRetirementInfo(birthDate, True) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If result = "يرجى إدخال تاريخ ميلاد صالح" Then ' إذا كان هناك خطأ، تبقى الحقول فارغة (تم تفريغها مسبقًا) Else ' إذا تم تمرير txtAllDetails، اعرض السلسلة الكاملة فيه If Not txtAllDetails Is Nothing Then txtAllDetails.Value = result End If ' تقسيم السلسلة إلى أسطر لتعيين القيم في مربعات النصوص المنفصلة lines = Split(result, vbCrLf) For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If InStr(lines(i), "تاريخ الميلاد: ") > 0 And Not txtBirthDate Is Nothing Then txtBirthDate.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "سن التقاعد: ") > 0 And Not txtRetirementAge Is Nothing Then txtRetirementAge.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "تاريخ التقاعد: ") > 0 And Not txtRetirementDate Is Nothing Then txtRetirementDate.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "السنوات المتبقية: ") > 0 And Not txtRemainingYears Is Nothing Then txtRemainingYears.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر المتبقية: ") > 0 And Not txtRemainingMonths Is Nothing Then txtRemainingMonths.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام المتبقية: ") > 0 And Not txtRemainingDays Is Nothing Then txtRemainingDays.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 Next i End If End If End Sub ' إجراء لعرض تعليمات حول استخدام وحدة سن التقاعد ' الغرض: تقديم إرشادات بسيطة للمستخدم حول كيفية استخدام الدوال Public Sub ShowRetirementHelp() Dim helpMessage As String helpMessage = "تعليمات استخدام وحدة سن التقاعد:" & vbCrLf & vbCrLf & _ "1. GetRetirementInfo(birthDate, [showDetails]):" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب، مثال: '2/19/1980')" & vbCrLf & _ " - showDetails: اختياري (True للحصول على التفاصيل الكاملة، False لتاريخ التقاعد فقط)" & vbCrLf & _ " - الإرجاع: سلسلة نصية تحتوي على تاريخ التقاعد أو التفاصيل الكاملة" & vbCrLf & vbCrLf & _ "2. PopulateRetirementFields(frm, birthDate, [txtBirthDate], [txtRetirementAge], " & _ "[txtRetirementDate], [txtRemainingYears], [txtRemainingMonths], [txtRemainingDays], [txtAllDetails]):" & vbCrLf & _ " - frm: النموذج الحالي (مطلوب)" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب)" & vbCrLf & _ " - txtBirthDate إلخ: كائنات مربعات النصوص لعرض القيم المنفصلة (اختياري، مثال: Me.txtBirth)" & vbCrLf & _ " - txtAllDetails: كائن مربع النص لعرض السلسلة الكاملة (اختياري، مثال: Me.txtRetirementDetails)" & vbCrLf & _ " - مثال: PopulateRetirementFields Me, Me.TEmp_BirthDate, Me.txtBirth, Me.txtRetAge, Me.txtRetirement, " & _ "Me.txtYearsLeft, Me.txtMonthsLeft, Me.txtDaysLeft, Me.txtRetirementDetails" & vbCrLf & vbCrLf & _ "ملاحظات: إذا لم يتم تمرير كائن مربع نص، يتم تجاهله دون إيقاف التنفيذ." MsgBox helpMessage, vbInformation, "تعليمات وحدة سن التقاعد" End Sub الاكواد النهائية بعد التطوير فى الوحده النمطية لحساب العمر Option Compare Database Option Explicit '------------------------------------------------------------ ' وحدة لحساب العمر بدقة بناءً على تاريخ الميلاد ' تحتوي على دالتين رئيسيتين: ' 1. GetAgeInfo: لحساب العمر (سنوات، أشهر، أيام) وإرجاعه كسلسلة نصية ' 2. PopulateAgeFields: لتوزيع النتائج على مربعات نصوص في نموذج '------------------------------------------------------------ ' دالة لحساب العمر بدقة بناءً على تاريخ الميلاد ' الغرض: تحديد العمر بالسنوات والأشهر والأيام من تاريخ الميلاد إلى التاريخ الحالي ' المعاملات: ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' الإرجاع: سلسلة نصية تحتوي على العمر أو رسالة خطأ إذا كان المدخل غير صالح Public Function GetAgeInfo(birthDate As Variant) As String Dim ageYears As Integer ' متغير لتخزين عدد السنوات في العمر Dim ageMonths As Integer ' متغير لتخزين عدد الأشهر في العمر Dim ageDays As Integer ' متغير لتخزين عدد الأيام في العمر Dim currentDate As Date ' متغير لتخزين التاريخ الحالي Dim tempDate As Date ' متغير مؤقت للمساعدة في الحسابات التدريجية Dim result As String ' متغير لتخزين النتيجة النهائية كسلسلة نصية ' التحقق من صحة تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" ' إرجاع رسالة خطأ إذا كان التاريخ فارغًا أو غير صالح Else birthDate = CDate(birthDate) ' تحويل المدخل إلى تاريخ currentDate = Date ' تعيين التاريخ الحالي ' التأكد من أن تاريخ الميلاد قبل التاريخ الحالي If birthDate > currentDate Then result = "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي" ' رسالة خطأ إذا كان التاريخ مستقبليًا Else ' حساب السنوات باستخدام الفرق بين تاريخ الميلاد والتاريخ الحالي ageYears = DateDiff("yyyy", birthDate, currentDate) tempDate = DateAdd("yyyy", ageYears, birthDate) ' تصحيح السنوات إذا تجاوز التاريخ المؤقت التاريخ الحالي If tempDate > currentDate Then ageYears = ageYears - 1 tempDate = DateAdd("yyyy", ageYears, birthDate) End If ' حساب الأشهر تدريجيًا ageMonths = 0 While DateAdd("m", 1, tempDate) <= currentDate ageMonths = ageMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام باستخدام الفرق بين التاريخ المؤقت والتاريخ الحالي ageDays = DateDiff("d", tempDate, currentDate) ' تجميع النتيجة كسلسلة نصية تحتوي على تفاصيل العمر result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "السنوات: " & ageYears & vbCrLf & _ "الأشهر: " & ageMonths & vbCrLf & _ "الأيام: " & ageDays End If End If GetAgeInfo = result ' إرجاع النتيجة النهائية End Function ' إجراء لتوزيع تفاصيل العمر على مربعات نصوص في نموذج ' الغرض: أخذ نتائج GetAgeInfo وتعيينها في مربعات نصوص منفصلة ' المعاملات: ' - frm (Form): النموذج الذي يحتوي على مربعات النصوص ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - txtYears, txtMonths, txtDays (TextBox, اختياري): كائنات مربعات النصوص للسنوات والأشهر والأيام Public Sub PopulateAgeFields(frm As Form, birthDate As Variant, _ Optional txtYears As TextBox, Optional txtMonths As TextBox, _ Optional txtDays As TextBox) Dim result As String ' متغير لتخزين النتيجة من GetAgeInfo Dim lines() As String ' مصفوفة لتقسيم السلسلة إلى أسطر Dim i As Integer ' متغير للحلقة ' تفريغ جميع مربعات النصوص الممررة أولاً On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If Not txtYears Is Nothing Then txtYears.Value = "" If Not txtMonths Is Nothing Then txtMonths.Value = "" If Not txtDays Is Nothing Then txtDays.Value = "" On Error GoTo 0 ' التحقق من تاريخ الميلاد ومعالجته فقط إذا كان صالحًا If Not IsNull(birthDate) And IsDate(birthDate) Then ' استدعاء دالة GetAgeInfo لحساب العمر result = GetAgeInfo(birthDate) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If InStr(result, "يرجى إدخال تاريخ ميلاد صالح") > 0 Or InStr(result, "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي") > 0 Then ' إذا كان هناك خطأ، تبقى الحقول فارغة (تم تفريغها مسبقًا) Else ' تقسيم السلسلة إلى أسطر لتعيين القيم في مربعات النصوص lines = Split(result, vbCrLf) ' تعيين القيم لمربعات النصوص بناءً على الكائنات الممررة For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If InStr(lines(i), "السنوات: ") > 0 And Not txtYears Is Nothing Then txtYears.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر: ") > 0 And Not txtMonths Is Nothing Then txtMonths.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام: ") > 0 And Not txtDays Is Nothing Then txtDays.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 Next i End If End If End Sub ' إجراء لعرض تعليمات حول استخدام وحدة حساب العمر ' الغرض: تقديم إرشادات بسيطة للمستخدم حول كيفية استخدام الدوال Public Sub ShowAgeHelp() Dim helpMessage As String helpMessage = "تعليمات استخدام وحدة حساب العمر:" & vbCrLf & vbCrLf & _ "1. GetAgeInfo(birthDate):" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب، مثال: '2/19/1980')" & vbCrLf & _ " - الإرجاع: سلسلة نصية تحتوي على العمر (سنوات، أشهر، أيام)" & vbCrLf & vbCrLf & _ "2. PopulateAgeFields(frm, birthDate, [txtYears], [txtMonths], [txtDays]):" & vbCrLf & _ " - frm: النموذج الحالي (مطلوب)" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب)" & vbCrLf & _ " - txtYears, txtMonths, txtDays: كائنات مربعات النصوص للسنوات والأشهر والأيام (اختياري، مثال: Me.txtAgeYears)" & vbCrLf & _ " - مثال: PopulateAgeFields Me, Me.TEmp_BirthDate, Me.txtAgeYears, Me.txtAgeMonths, Me.txtAgeDays" & vbCrLf & vbCrLf & _ "ملاحظات: إذا لم يتم تمرير كائن مربع نص، يتم تجاهله دون إيقاف التنفيذ." MsgBox helpMessage, vbInformation, "تعليمات وحدة حساب العمر" End Sub الاكواد داخل النموذج Option Compare Database Option Explicit Private Sub GetFullInfoByBirthDate() ' تفريغ جميع الحقول غير المرتبطة في كل مرة يتم تحميل سجل جديد On Error Resume Next ' تجاهل الأخطاء إذا كان أي مربع غير موجود Me.txtBirth.Value = "" Me.txtRetAge.Value = "" Me.txtRetirement.Value = "" Me.txtYearsLeft.Value = "" Me.txtMonthsLeft.Value = "" Me.txtDaysLeft.Value = "" Me.txtRetirementDetails.Value = "" Me.txtAgeYears.Value = "" Me.txtAgeMonths.Value = "" Me.txtAgeDays.Value = "" On Error GoTo 0 ' التحقق من وجود تاريخ ميلاد صالح قبل استدعاء الدوال If Not IsNull(Me.TEmp_BirthDate) And IsDate(Me.TEmp_BirthDate) Then ' استدعاء الدالة العامة الخاصة بالتقاعد مع تمرير النموذج وأسماء مربعات النصوص PopulateRetirementFields Me, Me.TEmp_BirthDate, , Me.txtRetAge, Me.txtRetirement, Me.txtYearsLeft, Me.txtMonthsLeft, Me.txtDaysLeft, Me.txtRetirementDetails PopulateAgeFields Me, Me.TEmp_BirthDate, Me.txtAgeYears, Me.txtAgeMonths, Me.txtAgeDays End If End Sub Private Sub Form_Current() GetFullInfoByBirthDate End Sub Private Sub TEmp_BirthDate_AfterUpdate() GetFullInfoByBirthDate End Sub Private Sub btnShowRetirementHelp_Click() ShowRetirementHelp End Sub Private Sub btnShowAgeHelp_Click() ShowAgeHelp End Sub سن التقاعد (5).accdb

لا أزايد على الأستاذ @Barna الغالي فيما تفضل به ، ولكن لضمان عرض الرسالة بشكل منطقي وسهل القراءة ، اعتقد اضافة الجزء vbMsgBoxRight لتحويل نص الرسالة من اليمين الى اليسار كقراءة لللغة العربية سيكون أفضل أيضاً

الفراغ الذي دار الحديث حوله اذا كان مربع النص حقل نصي ، إما اذا كان حقل رقمي فلا حاجة لـ Trim باعتقادي 😁 ولا في حد عنده اعتراض هههههههه

ما دام الأمر متوسعاً إلى هذا الحد 😁 ، فهذه فكرتي المتواضعة البسيطة ، وتضم 3 طرق بشكل (مباشر وغير مباشر ) لتحقيق الهدف مديول عام يضم الأساليب الثلاثة كالتالي :- ' الدالة الأولى: حساب تاريخ التقاعد فقط Public Function CalculateRetirementDate(birthDateControl As Object) As Variant Dim birthDate As Date Dim retirementAge As Integer Dim retirementDate As Date Dim inputDate As String If IsNull(birthDateControl.Value) Or birthDateControl.Value = "" Then MsgBox "يرجى إدخال تاريخ ميلاد", vbExclamation + vbMsgBoxRight CalculateRetirementDate = Null Exit Function End If If Not IsDate(birthDateControl.Value) Then MsgBox "تاريخ الميلاد غير صحيح . يرجى إدخال تاريخ بتنسيق صحيح (يوم/شهر/سنة)", vbExclamation + vbMsgBoxRight CalculateRetirementDate = Null Exit Function End If birthDate = CDate(birthDateControl.Value) If birthDate > Date Then MsgBox "تاريخ الميلاد لا يمكن أن يكون في المستقبل", vbExclamation + vbMsgBoxRight CalculateRetirementDate = Null Exit Function End If If Year(birthDate) < 1900 Then MsgBox "تاريخ الميلاد غير منطقي. يرجى إدخال تاريخ صحيح", vbExclamation + vbMsgBoxRight CalculateRetirementDate = Null Exit Function End If Select Case Year(birthDate) Case Is < 1960 retirementAge = 60 Case 1960 To 1964 retirementAge = 61 Case 1965 To 1969 retirementAge = 62 Case 1970 To 1974 retirementAge = 63 Case 1975 To 1979 retirementAge = 64 Case Is >= 1980 retirementAge = 65 Case Else MsgBox "تاريخ الميلاد خارج نطاق الحساب", vbExclamation + vbMsgBoxRight CalculateRetirementDate = Null Exit Function End Select retirementDate = DateAdd("yyyy", retirementAge, birthDate) - 1 CalculateRetirementDate = retirementDate End Function ' الدالة الثانية: حساب تاريخ التقاعد فقط (غير منضم) Public Function GetRetirementDateByBirth(birthDateInput As Object) As Variant Dim inputBirthDate As Date Dim ageAtRetirement As Integer Dim calculatedRetirementDate As Date If IsNull(birthDateInput.Value) Or birthDateInput.Value = "" Then GetRetirementDateByBirth = "لم يتم إدخال تاريخ ميلاد لهذا الموظف" Exit Function End If If IsDate(birthDateInput.Value) Then inputBirthDate = CDate(birthDateInput.Value) Select Case Year(inputBirthDate) Case Is < 1960 ageAtRetirement = 60 Case 1960 To 1964 ageAtRetirement = 61 Case 1965 To 1969 ageAtRetirement = 62 Case 1970 To 1974 ageAtRetirement = 63 Case 1975 To 1979 ageAtRetirement = 64 Case Is >= 1980 ageAtRetirement = 65 Case Else MsgBox "تاريخ الميلاد خارج نطاق الحساب", vbExclamation + vbMsgBoxRight GetRetirementDateByBirth = Null Exit Function End Select calculatedRetirementDate = DateAdd("yyyy", ageAtRetirement, inputBirthDate) - 1 GetRetirementDateByBirth = calculatedRetirementDate Else MsgBox "يرجى إدخال تاريخ ميلاد صحيح", vbExclamation + vbMsgBoxRight GetRetirementDateByBirth = Null End If End Function ' الدالة الثالثة: حساب تاريخ التقاعد مع المدة المتبقية Public Function CalculateRetirementInfo(birthDateField As Object) As String Dim employeeBirthDate As Date Dim retirementAge As Integer Dim retirementDate As Date Dim timeRemaining As String Dim currentDate As Date currentDate = Date If IsNull(birthDateField.Value) Or birthDateField.Value = "" Then CalculateRetirementInfo = "لم يتم إدخال تاريخ ميلاد لهذا الموظف" Exit Function End If If IsDate(birthDateField.Value) Then employeeBirthDate = CDate(birthDateField.Value) Select Case Year(employeeBirthDate) Case Is < 1960 retirementAge = 60 Case 1960 To 1964 retirementAge = 61 Case 1965 To 1969 retirementAge = 62 Case 1970 To 1974 retirementAge = 63 Case 1975 To 1979 retirementAge = 64 Case Is >= 1980 retirementAge = 65 Case Else CalculateRetirementInfo = "تاريخ الميلاد خارج نطاق الحساب" Exit Function End Select retirementDate = DateAdd("yyyy", retirementAge, employeeBirthDate) - 1 timeRemaining = GetTimeRemaining(currentDate, retirementDate) CalculateRetirementInfo = "تاريخ سن التقاعد في : " & Format(retirementDate, "dd/mm/yyyy") & " ، وبقي عليه " & timeRemaining Else CalculateRetirementInfo = "تاريخ الميلاد غير صحيح" End If End Function ' دالة مساعدة: حساب الفرق بين تاريخين Public Function GetTimeRemaining(startDate As Date, endDate As Date) As String Dim yearsDiff As Integer Dim monthsDiff As Integer Dim daysDiff As Integer Dim yearsText As String Dim monthsText As String Dim daysText As String yearsDiff = DateDiff("yyyy", startDate, endDate) If DateAdd("yyyy", yearsDiff, startDate) > endDate Then yearsDiff = yearsDiff - 1 End If monthsDiff = DateDiff("m", DateAdd("yyyy", yearsDiff, startDate), endDate) If DateAdd("m", monthsDiff, DateAdd("yyyy", yearsDiff, startDate)) > endDate Then monthsDiff = monthsDiff - 1 End If daysDiff = DateDiff("d", DateAdd("m", monthsDiff, DateAdd("yyyy", yearsDiff, startDate)), endDate) Select Case yearsDiff Case 1, 2 yearsText = "سنة" Case 3 To 10 yearsText = "سنوات" Case Else yearsText = "سنة" End Select Select Case monthsDiff Case 1, 2 monthsText = "شهر" Case 3 To 10 monthsText = "أشهر" Case Else monthsText = "شهر" End Select Select Case daysDiff Case 1, 2 daysText = "يوم" Case 3 To 10 daysText = "أيام" Case Else daysText = "يوم" End Select GetTimeRemaining = yearsDiff & " " & yearsText & " و " & monthsDiff & " " & monthsText & " و " & daysDiff & " " & daysText End Function والفكرة الأولى لحدث بعد التحديث لمربع نص تاريخ الميلاد = الفكرة الأولى تتحقق بشكل مباشر من خلال حدث بعد التحديث دون دالة في وحدة نمطية Private Sub TEmp_BirthDate_AfterUpdate() Dim birthDate As Date Dim retirementAge As Integer Dim retirementDate As Date If IsDate(Me.TEmp_BirthDate) Then birthDate = Me.TEmp_BirthDate Select Case Year(birthDate) Case Is < 1959 retirementAge = 60 Case 1959 To 1961 retirementAge = 61 Case 1962 To 1964 retirementAge = 62 Case 1965 To 1967 retirementAge = 63 Case 1968 To 1970 retirementAge = 64 Case Is >= 1971 retirementAge = 65 Case Else MsgBox "تاريخ الميلاد خارج نطاق الحساب", vbExclamation + vbMsgBoxRight Exit Sub End Select retirementDate = DateAdd("yyyy", retirementAge, birthDate) - 1 Me.M2 = retirementDate Else MsgBox "يرجى إدخال تاريخ ميلاد صحيح", vbExclamation End If End Sub والفكرة الثانية لحدث بعد التحديث لمربع نص تاريخ الميلاد = 'الفكرة الثانية تتحقق بشكل مباشر من خلال حدث بعد التحديث باستخدام دالة في وحدة نمطية Private Sub TEmp_BirthDate_AfterUpdate() Dim retirementDate As Variant retirementDate = CalculateRetirementDate(Me.TEmp_BirthDate) If Not IsNull(retirementDate) Then Me.M2 = retirementDate End If End Sub الفكرة الثالثة والرابعة من خلال مصدر بيانات مربع النص لمربع سن التقاعد أو المعاش = =GetRetirementDateByBirth([TEmp_BirthDate]) أو لإظهار التفاصيل للمدة المتبقية مع تاريخ سن التقاعد أو المعاش = =CalculateRetirementInfo([TEmp_BirthDate]) سن التقاعد.accdb

وعليكم السلام ورحمة الله تعالى وبركاته إدن لنجرب هدا الخلية N6 ="الالتزام "&INDEX({"الأول","الثاني","الثالث","الرابع","الخامس","السادس"}, ROW(A1)) الخلية L6 =IFERROR(INDEX($E$8:$E$367, MATCH(0, COUNTIF($L$5:L5, $E$8:$E$367), 0)), 0) الخلية K6 =IF(L6=0, 0, IF(L6<>"", COUNTIFS($E$8:$E$367, L6, $E$8:$E$367, "<>"), "0")) مع سحب المعادلات للأسفل Book2-V3.xlsx

عليكم السلام ورحمة الله وبركاته يمكنك تحقيق ذلك بسهولة من خلال تنسيق الشكل (Shape) في Excel بحيث تكون الصورة على الجانب الأيسر والنص على الجانب الأيمن داخل نفس الشكل. إليك الطريقة: الخطوات: إدراج الشكل: قم بإدراج شكل من خلال علامة التبويب "Insert" ثم اختر "Shapes". أو Word Art إضافة النص انقر على الشكل لكتابة النص داخله. لتحريك النص إلى الجانب الأيمن، استخدم أزرار المحاذاة لليمين أو اليسار. إضافة الصورة داخل الشكل: انقر بزر الماوس الأيمن على الشكل واختر "Format Shape". اختر "Fill" ثم "Picture or texture fill". اضغط على "Insert " أسفل كلمة Picture لإدراج الصورة التي تريدها. lمن جهاز الكمبيوتر أو يمكنك استعمال ايقونة Icon ضبط الصورة داخل الشكل: ضمن إعدادات "Format Shape"، اختر خيار "picture " إذا كنت تريد التحكم في موضع الصورة. ضمن جزء Crop قم بتعديل إعدادات " Offset Y Or X" (إزاحة) للصورة بحيث تظهر على الجانب الأيسر من الشكل. يمكنك تعديل العرض Width والارتفاع Height لضبط حجم الصورة بجانب النص نصيحة إضافية: إذا كنت تريد نتيجة أكثر دقة أو تحتاج إلى المزيد من التحكم، يمكنك استخدام برنامج تصميم مثل PowerPoint أو Word لإنشاء الشكل وتنسيقه، ثم إدراجه كصورة في Excel. بالتوفيق زر يحتوي على نص وصورة أو ايقونة.xlsb

السلام عليكم إخوتي الكرام بعد إذن الأخ الكريم الذي وصل إلى النتيجة ، إليكم طريقة أخرى بمعادلة واحدة فقط =IF(1*TEXT(EOMONTH(TODAY();0);"dd")>30;EOMONTH(TODAY();0)-4-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=30;EOMONTH(TODAY();0)-3-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=29;EOMONTH(TODAY();0)-2-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=28;EOMONTH(TODAY();0)-1-TODAY()&"يوم")))) وهناك معادلة أخرى فقط للملاحظة قد لا يحتاجها الأخ السائل: =" باقي"&$C$5&" "&"بناء على تاريخ نزول الراتب والذي يوافق يوم 27 من كل شهر ميلادي" والله ولي التوفيق ..والسلام عليكم موعد الرواتب.xlsx