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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي DurationToFullWords ، وهي تقوم بحساب الفارق بين تاريخين معينين (StartDate و EndDate) وتنسيق النتيجة بشكل نصي باستخدام الوحدات الزمنية مثل "سنة" ، "شهر" ، و "يوم" . كما تدعم العديد من الخيارات لتخصيص المخرجات مثل تحديد تنسيق النتيجة وإظهار الأرقام مع الكلمات العربية . 1️⃣ الجزء الأول تعريف المعاملات والتأكد من صحة البيانات المدخلة :- وقد تم تعديل الفكرة بحيث يستقبل الكود التاريخين الأصغر أولاً ثم الأكبر بغض النظر عن ما اذا كان مربع النص الأول يضم تاريخ أكبر أم أصغر .. If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If حيث StartDate و EndDate هما التاريخان اللذان يتم مقارنة الفارق بينهما . أولاً يتم التأكد من أن كلا التاريخين مدخلين بشكل صحيح (غير فارغين) . ثم يقارن اي القيمتين أسغر لجعلها بداية والأكبر نهاية 😁 . 2️⃣ الجزء الثاني حساب الفارق بين التواريخ :- y = DateDiff("yyyy", tempDate, EndDate) m = DateDiff("m", tempDate, EndDate) d = DateDiff("d", tempDate, EndDate) totalDays = DateDiff("d", StartDate, EndDate) حيث DateDiff هي دالة تستخدم لحساب الفرق بين التواريخ بوحدات مختلفة مثل السنوات (yyyy) ، الأشهر (m) ، و الأيام (d) . فيتم حساب الفرق بالسنوات أولاً ، ثم الأشهر ، وأخيراً الأيام . ثم يتم جمع totalDays لحساب الفارق الإجمالي بالأيام بين التاريخين . 3️⃣ الجزء الثالث المعالجة الخاصة للأشهر والأيام :- If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If حيث RoundResults هو خيار اختياري لتقريب النتائج . فإذا كان هذا الخيار مفعلًا ، يتم تعديل الأشهر أو الأيام ليتم تقريبها بشكل منطقي . فإذا كانت الأشهر 11 شهراً والأيام 25 أو أكثر ، يتم زيادة السنة بمقدار واحد . وإذا كانت الأشهر 5 والأيام 25 أو أكثر ، يتم تحويل الأشهر إلى 6 . 4️⃣ الجزء الرابع تنسيق النتائج حسب الخيارات :- Select Case FormatOption Case "Y" ' تنسيق الفرق بالسنوات فقط Case "M" ' تنسيق الفرق بالأشهر فقط Case "D" ' تنسيق الفرق بالأيام فقط Case "M/D" ' تنسيق الفرق بالأشهر والأيام Case "Y/M" ' تنسيق الفرق بالسنوات والأشهر Case Else ' تنسيق كامل (سنوات، أشهر، أيام) End Select التوضيح على شكل نقاط :- تعتمد الدالة على FormatOption لتحديد التنسيق الذي يجب أن تظهر به النتيجة ، كالتالي :- Y : يعرض النتيجة بالسنوات فقط . M : يعرض النتيجة بالأشهر فقط . D : يعرض النتيجة بالأيام فقط . M/D : يعرض النتيجة بالأشهر والأيام . Y/M : يعرض النتيجة بالسنوات والأشهر . القيمة الافتراضية : يعرض النتيجة كاملة (سنوات ، أشهر ، أيام) . 5️⃣ الجزء الخامس الدوال المساعدة :- Function SimpleUnit(Number As Long, UnitName As String) As String وتقوم هذه الدالة بـ :- بتنسيق الأرقام مع الوحدات الزمنية مثل "سنة" ، "شهر" ، أو "يوم" . تتعامل مع العدد بصيغة الجمع أو المفرد حسب الرقم المدخل . على سبيل المثال ، إذا كان العدد 1 ، يتم إرجاع "1 سنة" أو "1 شهر"، وإذا كان العدد 2 يتم إرجاع "سنتين" أو "شهرين" ... إلخ . Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String وتقوم هذه الدالة بتنسيق الأرقام مع الوحدات بشكل معين . على سبيل المثال :- OnlyNumbers : إذا كان True ، تعرض الأرقام فقط . ShowNumberWithWord : إذا كان True ، تعرض الرقم مع الكلمة باللغة العربية في قوسين مثل : "5 (خمسة) سنوات" . Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية . كما أنها تدعم الكلمة بصيغة المذكر أو المؤنث حسب القيمة المدخلة في IsFeminine . Function NumberWithUnitArabic(Number As Long, UnitName As String) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية مع الوحدة المناسبة (مثل "سنة واحدة" ، "شهران" ، "أيام") . 6️⃣ الجزء السادس التعامل مع الحروف العطف (مثل "و" ) .في الجزء :- If Right(result, 3) = " و " Then result = Left(result, Len(result) - 3) End If فبعد تنسيق النتيجة ، يتم إزالة الفاصلة الزائدة "و" في النهاية إذا كانت موجودة . 7️⃣ الجزء السابع : النتيجة النهائية :- If result = "" Then result = "أقل من يوم" DurationToFullWords = result في حال كانت النتيجة فارغة ( قيمة بفارق 0 ) ، يتم تعيين النتيجة إلى "أقل من يوم" . 💢 تم إضافة دالة تقوم بتفقيط التاريخ بأكثر من شكل ( 3 تنسيقات ) ، على سبيل المثال ، تاريخ اليوم هو 08/04/2025 والنتيجة له :- الثامن من شهر نيسان لعام ألفين وخمسة وعشرين م الثامن من شهر أبريل لعام ألفين وخمسة وعشرين م والجزء الجديد هو قراءة التاريخ بالأشهر الهجرية :- الثامن من شهر ربيع ثان لعام ألفين وخمسة وعشرين هـ 📛 الآن الكود العام في مديول منفرد :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit Function DurationToFullWords(StartDate As Variant, EndDate As Variant, _ Optional FormatOption As String = "", _ Optional ShortFormat As Boolean = False, _ Optional OnlyNumbers As Boolean = False, _ Optional ShowNumberWithWord As Boolean = False, _ Optional RoundResults As Boolean = False) As String If FormatOption = "" Then FormatOption = "FullWords" Dim y As Long, m As Long, d As Long Dim tempDate As Date Dim Result As String Dim totalMonths As Long Dim totalDays As Long Dim weeks As Long If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If tempDate = StartDate totalDays = DateDiff("d", StartDate, EndDate) y = DateDiff("yyyy", tempDate, EndDate) If DateAdd("yyyy", y, tempDate) > EndDate Then y = y - 1 tempDate = DateAdd("yyyy", y, tempDate) m = DateDiff("m", tempDate, EndDate) If DateAdd("m", m, tempDate) > EndDate Then m = m - 1 tempDate = DateAdd("m", m, tempDate) d = DateDiff("d", tempDate, EndDate) totalMonths = (y * 12) + m weeks = totalDays \ 7 If ShortFormat Then If y > 0 Then Result = Result & SimpleUnit(y, "سنة") & " و " If m > 0 Then Result = Result & SimpleUnit(m, "شهر") & " و " If d > 0 Then Result = Result & SimpleUnit(d, "يوم") & " و " Else If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If End If Select Case FormatOption Case "Y" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) Else If m < 6 Then Result = "أقل من نصف سنة" ElseIf m = 6 And d = 0 Then Result = "نصف سنة" ElseIf m = 6 And d > 0 Then Result = "أكثر من نصف سنة" ElseIf m > 6 Then Result = "أكثر من نصف سنة" End If End If Case "M" If totalMonths > 0 Then Result = FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) ElseIf d > 0 Then If d = 30 Or d = 31 Then Result = "شهر" ElseIf d < 30 Then Result = "أقل من شهر" End If Else Result = "أقل من شهر" End If Case "D" Result = FormatNumberWithWord(totalDays, "يوم", OnlyNumbers, ShowNumberWithWord) Case "M/D" If totalMonths > 0 Then Result = Result & FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) If d > 0 Then Result = Result & " و " End If If d > 0 Then If d >= 7 And totalMonths = 0 Then Select Case weeks Case 1 Result = Result & "أسبوع" Case 2 Result = Result & "أسبوعان" Case 3 To 4 Result = Result & FormatNumberWithWord(weeks, "أسبوع", OnlyNumbers, ShowNumberWithWord) Case Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End If End If Case "Y/M" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) Case Else If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) & " و " If d > 0 Then Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select End If If Right(Result, 3) = " و " Then Result = Left(Result, Len(Result) - 3) End If If Result = "" Then Result = "أقل من يوم" DurationToFullWords = Result End Function Function SimpleUnit(Number As Long, UnitName As String) As String Select Case Number Case 1 SimpleUnit = "1 " & UnitName Case 2 If UnitName = "سنة" Then SimpleUnit = "2 سنتين" ElseIf UnitName = "يوم" Then SimpleUnit = "2 يومين" Else SimpleUnit = "2 " & UnitName & "ين" End If Case 3 To 10 If UnitName = "سنة" Then SimpleUnit = Number & " سنوات" ElseIf UnitName = "شهر" Then SimpleUnit = Number & " أشهر" ElseIf UnitName = "يوم" Then SimpleUnit = Number & " أيام" Else SimpleUnit = Number & " " & UnitName End If Case Else SimpleUnit = Number & " " & UnitName End Select End Function Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String If OnlyNumbers Then FormatNumberWithWord = SimpleUnit(Number, UnitName) ElseIf ShowNumberWithWord Then FormatNumberWithWord = Number & " (" & NumberToArabicUnit(Number, UnitName) & ")" Else FormatNumberWithWord = NumberToArabicUnit(Number, UnitName) End If End Function Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String Dim UnitsMasc, UnitsFem, Tens, TeensMasc, TeensFem, Hundreds UnitsMasc = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") UnitsFem = Array("", "واحدة", "اثنتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع") TeensMasc = Array("عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") TeensFem = Array("عشر", "إحدى عشرة", "اثنتا عشرة", "ثلاث عشرة", "أربع عشرة", "خمس عشرة", "ست عشرة", "سبع عشرة", "ثماني عشرة", "تسع عشرة") Tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") Hundreds = Array("", "مئة", "مئتان", "ثلاثمئة", "أربعمئة", "خمسمئة", "ستمئة", "سبعمئة", "ثمانمئة", "تسعمئة") Dim Words As String Dim n As Long Dim h, t, u As Integer If Number = 0 Then NumberToArabicWords = "صفر" Exit Function End If If Number = 10 Then NumberToArabicWords = IIf(IsFeminine, "عشر", "عشرة") Exit Function End If If Number > 999 Then Dim Thousands As Long Thousands = Number \ 1000 Words = NumberToArabicWords(Thousands, False) & " ألف" n = Number Mod 1000 If n > 0 Then Words = Words & " و " & NumberToArabicWords(n, IsFeminine) NumberToArabicWords = Words Exit Function End If h = Number \ 100 t = (Number Mod 100) \ 10 u = Number Mod 10 If h > 0 Then Words = Hundreds(h) If (Number Mod 100) >= 11 And (Number Mod 100) <= 19 Then If Words <> "" Then Words = Words & " و " If IsFeminine Then Words = Words & TeensFem((Number Mod 100) - 10) Else Words = Words & TeensMasc((Number Mod 100) - 10) End If Else Dim UnitsArray UnitsArray = IIf(IsFeminine, UnitsFem, UnitsMasc) If t > 1 Then If u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) & " و " & Tens(t) Else If Words <> "" Then Words = Words & " و " Words = Words & Tens(t) End If ElseIf u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) End If End If NumberToArabicWords = Words End Function Function NumberWithUnitArabic(Number As Long, UnitName As String) As String Dim Result As String Select Case UnitName Case "سنة" Select Case Number Case 1: Result = "سنة واحدة" Case 2: Result = "سنتان" Case 3 To 10: Result = Number & " سنوات" Case Else: Result = Number & " سنة" End Select Case "شهر" Select Case Number Case 1: Result = "شهر واحد" Case 2: Result = "شهران" Case 3 To 10: Result = Number & " أشهر" Case Else: Result = Number & " شهر" End Select Case "يوم" Select Case Number Case 1: Result = "يوم واحد" Case 2: Result = "يومان" Case 3 To 10: Result = Number & " أيام" Case Else: Result = Number & " يوم" End Select Case Else Result = Number & " " & UnitName End Select NumberWithUnitArabic = Result End Function Function NumberToArabicUnit(Number As Long, UnitName As String) As String Dim word As String Dim feminine As Boolean Select Case UnitName Case "سنة": feminine = True Case "شهر": feminine = False Case "يوم": feminine = False End Select Select Case Number Case 1 word = UnitName & " " & IIf(feminine, "واحدة", "واحد") Case 2 If feminine Then word = "سنتان" Else If UnitName = "يوم" Then word = "يومان" Else word = UnitName & "ان" End If End If Case 3 To 10 word = NumberToArabicWords(Number, feminine) If UnitName = "يوم" Then word = word & " أيام" ElseIf UnitName = "سنة" Then word = word & " سنوات" ElseIf UnitName = "شهر" Then word = word & " أشهر" End If Case Else word = NumberToArabicWords(Number, feminine) & " " & UnitName End Select NumberToArabicUnit = word End Function Function ConvertDateToText(ByVal DateValue As Date, _ Optional ByVal CalendarType As String = "Gregorian", _ Optional ByVal MonthNameStyle As String = "Standard") As String Dim dayNumber As Integer Dim monthNumber As Integer Dim yearNumber As Integer Dim dayText As String Dim monthText As String Dim yearText As String If LCase(CalendarType) = "hijri" Then dayNumber = Val(Format$(DateValue, "dd", vbCalHijri)) monthNumber = Val(Format$(DateValue, "mm", vbCalHijri)) yearNumber = Val(Format$(DateValue, "yyyy", vbCalHijri)) Else dayNumber = day(DateValue) monthNumber = month(DateValue) yearNumber = year(DateValue) End If Select Case dayNumber Case 1: dayText = "الأول" Case 2: dayText = "الثاني" Case 3: dayText = "الثالث" Case 4: dayText = "الرابع" Case 5: dayText = "الخامس" Case 6: dayText = "السادس" Case 7: dayText = "السابع" Case 8: dayText = "الثامن" Case 9: dayText = "التاسع" Case 10: dayText = "العاشر" Case 11: dayText = "الحادي عشر" Case 12: dayText = "الثاني عشر" Case 13: dayText = "الثالث عشر" Case 14: dayText = "الرابع عشر" Case 15: dayText = "الخامس عشر" Case 16: dayText = "السادس عشر" Case 17: dayText = "السابع عشر" Case 18: dayText = "الثامن عشر" Case 19: dayText = "التاسع عشر" Case 20: dayText = "العشرين" Case 21: dayText = "الحادي والعشرين" Case 22: dayText = "الثاني والعشرين" Case 23: dayText = "الثالث والعشرين" Case 24: dayText = "الرابع والعشرين" Case 25: dayText = "الخامس والعشرين" Case 26: dayText = "السادس والعشرين" Case 27: dayText = "السابع والعشرين" Case 28: dayText = "الثامن والعشرين" Case 29: dayText = "التاسع والعشرين" Case 30: dayText = "الثلاثين" Case 31: dayText = "الحادي والثلاثين" Case Else: dayText = CStr(dayNumber) End Select If LCase(CalendarType) = "hijri" Then monthText = Choose(monthNumber, _ "محرم", "صفر", "ربيع أول", "ربيع ثان", "جمادى أول", "جمادى ثان", _ "رجب", "شعبان", "رمضان", "شوال", "ذو القعدة", "ذو الحجة") ElseIf LCase(MonthNameStyle) = "syriac" Then monthText = Choose(monthNumber, _ "كانون الثاني", "شباط", "آذار", "نيسان", "أيار", "حزيران", _ "تموز", "آب", "أيلول", "تشرين الأول", "تشرين الثاني", "كانون الأول") Else monthText = Choose(monthNumber, _ "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") End If yearText = NumberToArabicText(yearNumber) Dim eraSuffix As String If LCase(CalendarType) = "hijri" Then eraSuffix = " هـ" Else eraSuffix = " م" End If ConvertDateToText = dayText & " من شهر " & monthText & " لعام " & yearText & eraSuffix End Function Function NumberToArabicText(ByVal TheNumber As Long) As String Dim MyArray1(0 To 9) As String Dim MyArray2(0 To 9) As String Dim MyArray3(0 To 9) As String Dim Result As String Dim Hundreds As String Dim Tens As String Dim Ones As String Dim AndConnector As String AndConnector = " و" MyArray1(0) = "" MyArray1(1) = "مائة" MyArray1(2) = "مائتين" MyArray1(3) = "ثلاثمائة" MyArray1(4) = "أربعمائة" MyArray1(5) = "خمسمائة" MyArray1(6) = "ستمائة" MyArray1(7) = "سبعمائة" MyArray1(8) = "ثمانمائة" MyArray1(9) = "تسعمائة" MyArray2(0) = "" MyArray2(1) = " عشر" MyArray2(2) = "عشرين" MyArray2(3) = "ثلاثين" MyArray2(4) = "أربعين" MyArray2(5) = "خمسين" MyArray2(6) = "ستين" MyArray2(7) = "سبعين" MyArray2(8) = "ثمانين" MyArray2(9) = "تسعين" MyArray3(0) = "" MyArray3(1) = "واحد" MyArray3(2) = "اثنين" MyArray3(3) = "ثلاثة" MyArray3(4) = "أربعة" MyArray3(5) = "خمسة" MyArray3(6) = "ستة" MyArray3(7) = "سبعة" MyArray3(8) = "ثمانية" MyArray3(9) = "تسعة" If TheNumber = 0 Then NumberToArabicText = "صفر" Exit Function End If Dim HundredsDigit As Integer Dim TensDigit As Integer Dim OnesDigit As Integer HundredsDigit = (TheNumber Mod 1000) \ 100 TensDigit = (TheNumber Mod 100) \ 10 OnesDigit = TheNumber Mod 10 If HundredsDigit >= 0 And HundredsDigit <= 9 Then Hundreds = MyArray1(HundredsDigit) Else Hundreds = "" End If If TensDigit = 1 Then Select Case OnesDigit Case 0: Tens = "عشرة" Case 1: Tens = "إحدى عشرة" Case 2: Tens = "إثنتا عشرة" Case Else: Tens = MyArray3(OnesDigit) & MyArray2(TensDigit) End Select Else Ones = MyArray3(OnesDigit) Tens = MyArray2(TensDigit) If Ones <> "" And Tens <> "" Then Tens = Ones & AndConnector & Tens Else Tens = Ones & Tens End If End If If Hundreds <> "" And Tens <> "" Then Result = Hundreds & AndConnector & Tens Else Result = Hundreds & Tens End If If TheNumber > 999 Then Dim Thousands As Long Dim Remainder As Long Thousands = TheNumber \ 1000 Remainder = TheNumber Mod 1000 Dim ThousandsText As String ThousandsText = NumberToArabicText(Thousands) If Thousands = 1 Then ThousandsText = "ألف" ElseIf Thousands = 2 Then ThousandsText = "ألفين" ElseIf Thousands >= 3 And Thousands <= 10 Then ThousandsText = NumberToArabicText(Thousands) & " آلاف" Else ThousandsText = NumberToArabicText(Thousands) & " ألف" End If If Remainder > 0 Then Result = ThousandsText & AndConnector & NumberToArabicText(Remainder) Else Result = ThousandsText End If End If NumberToArabicText = Result End Function ولتسهيل فهم الموضوع عند الإستدعاءات المختلفة ، تم انشاء نموذج بسيط يضم 22 زر ولكل زر طريقة استدعاء مختلفة تسهيلاً للمستخدم كي تتوضح له آلية العمل . كما تم اضافة 3 مربعات نص كل منها يعرض التفقيط بشكل مختلف . ♻ المرفق :- Date Duration to Arabic Words.accdb

وعليكم السلام ورحمة الله وبركاته .. التنسيقات والمسافات خطوة يتبعها مبرمجوا وكاتبوا الأكواد لتتبع بداية ونهاية الأجزاء ، وخصوصاً الجمل والدوال والأكواد التي لها بداية ونهاية مثل الجمل الشرطية If أو Select .... الخ لذا فهي ليست ذات أي تأثير على سرعة أداء الكود أو عدم فعاليته . وجهة نظري البسيطة ، والله تعالى أعلم

وعليكم السلام ورحمة الله وبركاته نم النظر في جميع الملاحظات وتم التعديل ان شاء الله مع ملاحظة اعادة معادلة الترقيم في شيت معاشات كنت جعلت الترقيم تلقائى لجعل الكود اسرع قحسب طلبك العدد سيكون اكثر من 10000 ومن اسباب ثقل الاكواد المعادلات وخاصة ان شيت DATA سيكون به اكثر من 70000 معادلة اذا كان عدد الموظفين اكثر من 10000 وعلى كل حال مواصفات الجهاز الجيدة لها دور كبير في سرعة معالجة البياتان اتمنى ان تجد طلبك في الملف ولا حرج في اي ملاحظات تراها تخدم العمل في ملفك حفظك الله برعايته ورزقك من ثمار الجنة ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 5.xlsb

بدايةً اعتذر عن عدم الرد سابقاً ، وان شاء الله إن استطعت الليلة سأقوم باقتراح نموذج يلبي الاحتياجات.

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

لو اقل من 138 يكون له برنامج علاجي اي مطلوب للنجاح 60% من الدرجة فأكثر يبدوا ان الأستاذ سعد فاته هذا الخطأ

السلام عليكم شرح توضيحي للحاصل وللمطلوب الحضور يتم ادخالها كدرجة مثلها مثل درجات المواد عبر نموذج frm_rsd_nshat علما ان الدرجات مدخلة والمطلوب اظهار النتيجة الدرجات المدخلة كاملة للصفوف : الصف الاول ويمثل الصفوف الدنيا / والصف السادس ويمثل الصفوف العليا / والصف الثالث ( طايح فراشين ) 🤣 نسبة الرسوب في مواد الرسوب 50% وفي الحضور 60% حقل الحضور موجود وظاهر فقط في تقريري الصفوف الدنيا للنصف الثاني : تقرير الكشف rep_B_Lo_kashf_term2 ويجب ان يأخذ اللونين الأزرق للنجاح والأحمر للرسوب + اذا رسب في الحضور تعتبر نتيجته راسب ومثله تقرير النتيجة rep_B_Lo_shhada_term2 .. لو تتبعت الدالات في الوحدة النمطية اتضح لك شروط النجاح في المادة ولو تتبعت الاكواد في محرر التقارير لاتضح لك شروط النجاح الكلي وكما ذكرت سابقا اني توصلت لحل يظهر النتيجة ولكني لم اقتنع به بسبب ان يطبق المثل وين اذنك يا جحا 😞 لذا اشرت عليه ان نشرك اخوتنا في ايجاد حلول

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

وعليكم السلام ورحمة الله وبركاته طلبك كبير ومهم جدًا لأي شخص يتعلم VBA في Excel. ارجو تحديد الاوامر المطلوب شرحها لان كل امر يحناج الى وقت لشرحه ويمكنك البحث في اليوتيوب تجد شروح عديدة ومفيدة في VBA – هناك فئات كثيرة من الأوامر: اهمها 🔹 1. التعامل مع الخلايا (Cells / Range) قراءة البيانات من خلايا متعددة - تغيير قيم مجموعة من الخلايا- التعامل مع نطاقات خلايا أكبر 🔹 2. التعامل مع الصفوف والأعمدة 🔹 3. التعامل مع الأوراق (Sheets) 🔹 4. التعامل مع المصنفات (Workbooks) 🔹 5. التعامل مع النصوص (Strings) 🔹 6. الرسائل (MsgBox و InputBox) إظهار رسالة تنبيه للمستخدم - استخدام InputBox للحصول على إدخال من المستخدم 🔹 7. التعامل مع البيانات (Data Manipulation) 🔹 8. التكرار (Loops) استخدام For Each للتكرار عبر مجموعة من الخلايا - استخدام حلقة For لتكرار الأوامر 🔹 9. المعاملات الشرطية (If و Select Case) استخدام If لتحديد شرط - استخدام Select Case بديلًا عن سلسلة If مع شروط متعددة 🔹 10. أوامر إيقاف الكود (Exit و End)

كلمة شكر لا تكفي بداية كل الشكر والعرفان بالجميل لكل القائمين على (أوفيسنا Excel) ذلك الصرح التعليمي الرائع الذي نتعلم منه ونلجأ إليه دوما عندما نجهل معلومة ما فنجد كل الدعم والمساعدة المجردة من أية أهواء أو أغراض والشكر موصول لجميع من ينتمي لهذا المنتدى التعليمي الخالص لوجه الله تعالى؛ وفي هذا المقام أحب أن يكون الشكر اليوم موصول كذلك لـ: § أخي في الله الأستاذ الفاضل علما وخلقا / عبد الله بشير عبد الله § ما شاء الله تبارك الله حفظك الله ورعاك أينما كنت وأينما حللت · حقيقة لا أعرف كيف أشكرك وجميع كلمات الشكر والثناء عاجزة عن أن توفيك حقك؛ ما أروعك وما أروع رقي تعاملكم معي وحرصكم على نشر العلم والمعرفة لمن يجهلها. v أدعو الله سبحانه وتعالى أن يجزيك بفضله ومن واسع عطائه وعلى قدر الله أجر: · رحابة وسعة صدرك وحلمك وصبرك على. · عدم تضجرك أو تأففك من كثرة تساؤلاتي وملاحظاتي. · سرعة ردكم وإجاباتكم الشافية الواعية عن ثقة وعلم وخبرة. · حسن متابعتكم لكل رد جديد على الموضوع والأروع والأجمل عباراتكم التي دوما تذيلون بها ردودكم مثل: ü جرب الملف واعلمنى بالنتائج. ü قم بتجربة الترحيل ولاحظ الترتيب وأي ملاحظات اذكرها وان شاء الله وبعونه نقوم بالواجب. ü أتمنى أن تجد طلبك في الملف ولا حرج في أي ملاحظات تراها تخدم العمل في ملفك. · وإن مثل هذه الردود تدل على رقي أخلاقكم ولا تأتي إلا ممن تمكن من علمه وأدواته زادكم الله من لدنه علما على علمكم. · كل ذلك أستاذي الفاضل ومعلمي رفع عني الحرج وجعلني أتجرأ وأسأل وبدون خشية وبكل أريحية عما أجهله وكلي ثقة ويقين بأني سأجد الرد والمعلومة الصحيحة ولوجه الله تعالى بدون بخل · وإني أستأذنكم في السماح لي بالسؤال في وقت لاحق بأمر الله تعالى حال ظهور أي استفسار أو ملحوظة بخصوص نفس الموضوع فالرجال أربعة: ü رجل يعلم.. ويعلم أنه يعلم *** فذلك (عالم) فصاحبوه واسألوه وتعلموا منه (وأنت منهم أستاذي الفاضل) ü ورجل يعلم.. ولا يعلم أنه يعلم *** فذلك (غافل) فأيقظوه ü ورجل لا يعلم.. ويعلم أنه لا يعلم *** فذلك (جاهل) فعلموه (وأنا منهم في الإكسيل) ü ورجل لا يعلم.. ولا يعلم أنه لا يعلم *** فذلك (أحمق) فاجتنبوه · وأخيرا وليس آخرا · أدعو الله عز وجل في علاه لكم ولنا ولكل من قرأ هذا التعليق: v أن يسعدكم الله في الدارين وأن يرزقكم بلا حساب وأن يفيض عليكم من علمه وأن يسقيكم من يد نبيه الشريفة شربة لا تظمأون بعدها أبدا وأن يجعل الفردوس الأعلى من الجنة مقاما ومستقرا لكم. آمين آمين آمين رب العالمين.

وإياكم معلمنا الجليل ، وبارك الله بكم وبصحتكم وعافيتكم ومالكم وأهلكم أجمعين .. نحاول السير على خطاكم ليس إلا 😊 . أهلا مهندسنا الغالي .. أشكر ثقتكم ودمعكم المتواصل .. وليس لي غنى عن مقترحاتكم وانتقاداتكم , وان شاء الله سأحاول إضافة الأفكار التي طرحتموها علها تكون ذات فائدة أكبر من خلال هذا العمل المتواضع . جزاكم الله خيراً أخي العزيز .. وبارك الله بكم ، شرفتموني بتعليقكم 😇 .

عمل رائع جدا جزاك الله خيرا وحعله في ميزان حسناتك

عمل إبداعي متميز .. من شخص ليس بغريب عليه الإبداع 🙂 فكرة رائعة ومتعددة الخيارات بكل ما يخطر على بال المستخدم .. ماشاء الله عندي مقترحين وهما لايغيران من جمال وروعة العمل : 😁🖐️ 1- بالنسبة لو تم إدخال تاريخ نهاية أصغر من تاريخ البداية .. أقترح أن يتم تبديلهما تلقائيا بدون رسائل خطأ ( يقدم التاريخ الأصغر كتاريخ بداية والأكبر كتاريخ نهاية ) <------ مجرد رأي 😎 2- حبذا لو تضيف خدمة تفقيط التواريخ (وليس الفرق بين تاريخين) ... مثال : 08/04/2024 ------(يصبح)--------> الثامن من شهر إبريل للعام ألفين وأربعة وعشرين للميلاد .. <------ مجرد إقتراح والباقي ما عليه كلام يا سيد المبدعين

فكرة جديدة غريبة والعمل مرتب ورائع .. اثابك الله على جهدك وتعبك .. وأحسن اليك

وعليكم السلام ورحمة الله وبركاته جزاك الله خيرا على دعاؤك الطيب لي واسأل الله ان يجازيك خير الجزاء تم تعديل الكود ليتعامل مع البيانات الكثيرة بالنسبة للاحصائيات جعلتها في اعلى الصفحة والكود يقوم بحسابها آليا - ووجودها اسفل الصفحة يعرقل عمل الكود وحاولت ولم اتوصل الى نتيحة مرضية (حسب علمي ) بالنسبة للنرنيب التصاعدي الكود يتعامل مع العمود L في شيت معاشات وجربنه ويعمل جيدا الملف المرفق به 7000 تقريبا صف طبعا قم بنجربة الترحيل ولاحظ الترتيب واي ملاحظات اذكرها وات شاء الله وبعونه تقوم بالواجب لك كل التقدير والاحترام ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 3.xlsb

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

السلام عليكم ورحمة الله تعالى وبركاته سوف اقدم لكم اليوم ان شاء الله تعالى فكرة أتمتة عمليات البيع بكل الطرق (FIFO , LIFO , HighestPrice , LatestPrice) ولكن أولا مقدمه بشكل نظرى عن هذه العبارة لتوضيح هذه المصطلحات هى تعنى أن النظام أو البرنامج يقوم بشكل آلي (تلقائي) باختيار الكمية المناسبة من المخزون عند تنفيذ عملية البيع، بناءً على طريقة معينة وذلك لتحديد أي دفعة (Batch) من المخزون سيتم السحب منها. هذه الطرق هي ما تُعرف بـ "سياسات تقييم المخزون أو صرف المخزون"، وشرحها كالتالي: FIFO (First In, First Out - الوارد أولاً يصرف أولاً) تعني أن النظام سيبدأ في بيع الكميات من أول دفعة تم شراؤها أو إدخالها للمخزون تخصم الكميات التي تُباع أولاً من أول دفعة تم شرائها. تستخدم غالبًا في المنتجات القابلة للتلف (مثل الطعام أو الدواء). مثال: اشتريت 100 وحدة بـ10 جنيه، ثم 100 وحدة بـ12 جنيه. عند بيع 50 وحدة، سيتم بيعهم من الدفعة الأولى (10 جنيه). LIFO (Last In, First Out - الوارد أخيراً يصرف أولاً) تعني أن النظام سيبدأ في بيع الكميات من آخر دفعة تم شراؤها تخصم الكميات التي تُباع أولاً من آخر دفعة تم شرائها. تُستخدم في بعض الأنظمة المحاسبية عند توقع ارتفاع الأسعار. مثال: نفس المثال السابق. عند بيع 50 وحدة، سيتم بيعهم من الدفعة الثانية (12 جنيه). HighestPrice (أعلى سعر أولاً) يعني أن النظام سيبدأ في بيع الكميات من الدُفَع ذات السعر الأعلى تخصم الكميات التي تُباع أولاً من الدفع ذات السعر الأعلى. مفيد في حالات تحسين الربحية أو تقليل الخسائر تُستخدم في حالات معينة عند الرغبة في التخلص من البضاعة ذات التكلفة الأعلى لتقليل الخسائر أو تقليل التكاليف المخزنية المرتفعة. مثال: عندك 3 دفعات بأسعار 10، 12، 15. النظام يبدأ البيع من الدفعة بسعر 15. LatestPrice (أحدث دفعة أولاً) المقصود هنا بيع الكمية من أحدث تاريخ شراء تخصم الكميات التي تُباع أولاً من الدفع ذات تاريخ الشراء الأحدث. يختلف عن LIFO بإنه يعتمد على تاريخ الشراء وليس ترتيب الإدخال. مفيد عندما تكون تواريخ الشراء غير مرتبة أو النظام يسمح بإدخال متأخر. التطبيق يعتمد على التالى جدول يحتوي على إعدادات طريقة البيع : tblSalesSettings المفروض الجدول يحتوى على سجل واحد فقط ويتم تحديد طريقة البيع حسب الرغبة او حسب النظام المحاسبى المتبع جدول المنتجات : tblProducts - يحتوي على بيانات المنتجات الأساسية. جدول الواردات : tblPurchaseBatches - يتبع كل دفعة شراء لمنتج معين. جدول لتسجيل عمليات الارتجاع : tblReturns - يتبع كل عمليات الإرتجاع بعد إتمام عملية شراء لمنتج معين. جدول تفاصيل كميات المبيعات حسب الدفعات : tblSaleBatchDetails- يتبع كل دفعة بيع لمنتج معين حسب الكمية وتبعا لمعرف الدغعات. جدول تفاصيل المبيعات : tblSaleDetails - يتبع كل المنتجات التى يتم بيعها داخل الفاتورة. جدول المبيعات : tblSales - يحتوي على إجمالي كل فاتورة. وأخيرا المرفق للتجربــــــــــــة ملاحظة لم أهتم بأى تفاصيل لا للحذف أو للارتجاع لانها لن يكون لها أى تأثير يذكر لأن الكميات يتم حسابها بناء على معرف الدفعات بشكل ديناميكى حسب المبيعات و بناء على الواردات للدفعات ما تم الاهتمام به فقط هو التعامل مع طرق البيع المختلفة لاصدار الفواتير او صرف الكميات حسب الطرق المحاسبية بشكل صحيح ومرن وبناء عليه حصر الكميات المتبقية يعنى ببساطه بيع وجرد فى نفس الوقت على اساس محاسبى صحيح بمرونة وفاعليه نسيت توضيح شئ مهم : مثلا يوجد وارد لمنتج بأكثر من دفعه ولكل دفعه سعر بيع وسعر شراء طيب لنفترض ان الدفعه 1 للمنتج 101 عدد الكميات لها 5 الدفعه 2 للمنتج 101 عدد الكميات لها 10 اذا اجمال الكميات هو 15 طيب عند اصدار الفاتورة مع الاختيار : FIFO من جدول اعدادت طرق البيع لنفترض اننا نريد بيع 8 قطع من ها المنتج فى هذه الحاله يتم عمل التالى صرف 5 من الدفعه 1 وصرف 3 من الدفعه 2 طيب سعر بيع الدفعه الاولى لو 120 وسعر بيع الدفعه الثانيه 130 يكون ( 5*120 ) + ( 3 * 130 ) = 600 + 390 = يكون الناتج 990 وفى هذه الحاله لا يتم كتابة سعر للوحده فى الفاتورة بل يتم حساب المتوسط أتمتة عمليات البيع بكل الطرق .accdb

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

وعليكم السلام ورحمة الله تعالى وبركاته صراحة أخي @algammal التعامل مع الملف باستخدام المعادلات لتنفيذ طلبك غير عملي خصوصا أنك ترغب في إمكانية الترقيم التلقائي عند حذف أو إضافة صفوف جديدة أو حتى جدول جديد ما يزيد من التعقيد هو وجود العديد من الخلايا المدمجة والصفوف الفارغة على عمود الترقيم أعتقد أن الحل الأنسب هنا هو استخدام الأكواد مجرد إقتراح ربما يناسبك الكود التالي يعمل بشكل ديناميكي ويتعرف تلقائيا على الجداول بناءا على كلمات مفتاحية تحدد بداية الجدول ونهايته قمت بتحديدها نظرا لشكل تصميمك للملف حيث يقوم الكود بالبحث عن كلمة "الاسم" في عمود B للتعرف على بداية الجدول ومن ثم يبحث عن كلمة "المختص" في نفس العمود لتحديد نهاية الجدول وبمجرد تحديد نطاق الجدول سيقوم الكود بإعادة الترقيم على الجداول المتواجدة في الملف داخل هذا النطاق في العمود A بداية من الصف 7 إذا قمت بتغيير هذه الكلمات المفتاحية عليك تعديلها داخل الكود أيضا لذلك ييفضل أن تحرص دائما على وجود هذه الكلمات في أماكنها لتضمن عمل الكود بشكل صحيح Private Sub Worksheet_Change(ByVal Target As Range) Dim SrcWS As Worksheet, Irow As Long, tmp As Long, n As Long, OnRng As Long, tbl As Long, i As Long Const StarTBL As String = "الاسم" Const EndTBL As String = "المختص" On Error GoTo ErrorData Set SrcWS = Me Irow = SrcWS.Cells(SrcWS.Rows.Count, "B").End(xlUp).Row SetApp False For tmp = 6 To Irow If Not SrcWS.Cells(tmp, "A").MergeCells Then SrcWS.Cells(tmp, "A").ClearContents Next tmp n = 1 tmp = 6 Do While tmp <= Irow If Trim(SrcWS.Cells(tmp, "B").Value) = StarTBL Then OnRng = tmp + 1 Do While Trim(SrcWS.Cells(tmp, "B").Value) <> EndTBL And tmp <= Irow tmp = tmp + 1 Loop tbl = tmp - 3 For i = OnRng To tbl If Not SrcWS.Cells(i, "A").MergeCells And SrcWS.Cells(i, "A").Value = "" Then SrcWS.Cells(i, "A").Value = n n = n + 1 End If Next i End If tmp = tmp + 1 Loop SetApp True Exit Sub ErrorData: End Sub Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

اسف جدا اخوي foksh ولكن ارجو من الله ثم منك اخوي المساعدة وانني محتاج لهذا الشرح اريد عندما يكون الصلاحية سنة يحسب من تاريخ الجهاز مثلا اخوي تاريخ اليوم 2025/04/08 1- عندما ادخل تاريخ البداية 2024/04/08 حتى 2025/04/08 هذة المدة طبعا سنة يكون اخضر او 2024/04/08 حتى 2026/04/08 سنتان اخضر 2- عندما ادخل تاريخ البداية 2024/04/07 حتى تاريخ امس2025/04/07 يكون احمر لان تاريخ اليوم في الجهاز 2025/04/08 هذا المطلوب والرجاء المساعدة اسف جدا على الاطالة

معليش اخوي Foksh واسف جدا على الاطالة والله يجعلها في موازين حسناتك يارب ويوفقك الشرح الاخير في المرفق ارجو الاطلاع تفقيط التاريخ 1 (2).accdb