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

في هذا الموضوع سنستعرض دالتين احترافيتين CountWeekday – لحساب عدد أيام محددة بين تاريخين CalculateMonthStats – لحساب إحصائيات شهرية لأي فترة زمنية الدوال مرنة، سريعة، وصحيحة حتى في الفترات الطويلة، ويمكن استخدامها لأي يوم من أيام الأسبوع وليس فقط الجمعة والسبت تعريف أيام الأسبوع Public Enum WeekDays wdSunday = 1 wdMonday = 2 wdTuesday = 3 wdWednesday = 4 wdThursday = 5 wdFriday = 6 wdSaturday = 7 End Enum دالة CountWeekday تحسب عدد أي يوم تختاره بين تاريخين مرنة: يمكن استخدامها لحساب أيام الأحد، الإثنين، الأربعاء، الجمعة … إلخ. سريعة وفعّالة دون الحاجة لتكرار كل يوم في الفترة. تتعامل مع التاريخ بشكل صحيح . الكود Public Function CountWeekday( _ ByVal StartDate As Date, _ ByVal EndDate As Date, _ ByVal TargetDay As WeekDays) As Long Dim TotalDays As Long, BaseCount As Long, ExtraDays As Long Dim FirstDay As Long, Offset As Long If StartDate > EndDate Then Exit Function TotalDays = DateDiff("d", StartDate, EndDate) + 1 If TotalDays <= 0 Then Exit Function BaseCount = TotalDays \ 7 ExtraDays = TotalDays Mod 7 FirstDay = Weekday(StartDate, vbSunday) Offset = (TargetDay - FirstDay + 7) Mod 7 CountWeekday = BaseCount If Offset < ExtraDays Then CountWeekday = CountWeekday + 1 End Function ------ دالة CalculateMonthStats تحسب إحصائيات الشهر: عدد الأيام الإجمالي عدد أيام الجمعة والسبت (يمكن تعديلها لأي أيام أخرى) عدد أيام العمل (باقي الأيام) الكود Public Type TMonthStats MonthName As String CalendarYear As Long FridayCount As Long SaturdayCount As Long TotalDays As Long WorkingDays As Long End Type Public Const MONTH_NAMES_AR As String = "يناير,فبراير,مارس,ابريل,مايو,يونيو,يوليو,أغسطس,سبتمبر,اكتوبر,نوفمبر,ديسمبر" Public Function GetArabicMonthName(ByVal MonthNumber As Long) As String Static arrMonths As Variant If IsEmpty(arrMonths) Then arrMonths = Split(MONTH_NAMES_AR, ",") If MonthNumber >= 1 And MonthNumber <= 12 Then GetArabicMonthName = arrMonths(MonthNumber - 1) End Function Public Function CalculateMonthStats( _ ByVal StartDate As Date, _ ByVal EndDate As Date, _ ByVal MonthNumber As Long, _ ByVal YearNumber As Long) As TMonthStats Dim result As TMonthStats result.MonthName = GetArabicMonthName(MonthNumber) result.CalendarYear = YearNumber result.TotalDays = DateDiff("d", StartDate, EndDate) + 1 result.FridayCount = CountWeekday(StartDate, EndDate, wdFriday) result.SaturdayCount = CountWeekday(StartDate, EndDate, wdSaturday) result.WorkingDays = result.TotalDays - result.FridayCount - result.SaturdayCount CalculateMonthStats = result End Function مميزات الدوال مرنة: تعمل لأي يوم تختاره سريعة وفعالة: تعتمد على القسمة والحسابات الرياضية صحيحة للفترات الطويلة: سواء أيام، أشهر أو سنوات تحقق تلقائي: لا تنتج أخطاء إذا كان تاريخ البداية أكبر من النهاية سهل التعديل: يمكن استخدام CountWeekday لحساب أيام محددة أخرى داخل CalculateMonthStats الفكرة العامة: باستخدام هاتين الدالتين، يمكنك: حساب عدد أي يوم من أيام الأسبوع بين تاريخين. بناء تقارير شهرية مع إحصاءات كاملة لأيام العمل والعطلات. التحكم الكامل في تحديد أيام العطلات أو الأيام المستثناة حسب الحاجة. وممكن التجربة من خلال الاكواد التالية '------------------------------------------------- ' اختبار حساب عدد أيام يوم محدد في فترة '------------------------------------------------- Public Sub TestCountSingleWeekday() Dim StartDate As Date Dim EndDate As Date Dim TargetDay As WeekDays Dim Count As Long ' مثال: من 1 مارس 2025 إلى 31 مارس 2025 StartDate = DateSerial(2025, 3, 1) EndDate = DateSerial(2025, 3, 31) ' اليوم المطلوب: الجمعة TargetDay = wdFriday ' حساب عدد الأيام Count = CountWeekday(StartDate, EndDate, TargetDay) ' طباعة النتيجة في النافذة الفورية Debug.Print "==============================" Debug.Print "اختبار CountWeekday:" Debug.Print "الفترة من: " & FormatDateValue(StartDate) Debug.Print "إلى: " & FormatDateValue(EndDate) Debug.Print "اليوم المطلوب: " & WeekdayName(TargetDay) Debug.Print "عدد الأيام: " & Count Debug.Print "==============================" End Sub '------------------------------------------------- ' اختبار حساب أكثر من يوم (مثلاً الجمعة والسبت) '------------------------------------------------- Public Sub TestCountMultipleWeekdays() Dim StartDate As Date Dim EndDate As Date Dim FridayCount As Long Dim SaturdayCount As Long ' مثال: من 1 أبريل 2025 إلى 30 أبريل 2025 StartDate = DateSerial(2025, 4, 1) EndDate = DateSerial(2025, 4, 30) ' حساب كل يوم على حدة FridayCount = CountWeekday(StartDate, EndDate, wdFriday) SaturdayCount = CountWeekday(StartDate, EndDate, wdSaturday) ' طباعة النتائج Debug.Print "==============================" Debug.Print "اختبار CountWeekday لعدة أيام:" Debug.Print "الفترة من: " & FormatDateValue(StartDate) Debug.Print "إلى: " & FormatDateValue(EndDate) Debug.Print "عدد أيام الجمعة: " & FridayCount Debug.Print "عدد أيام السبت: " & SaturdayCount Debug.Print "==============================" End Sub '------------------------------------------------- ' اختبار حساب كامل إحصاءات الشهر '------------------------------------------------- Public Sub TestCalculateMonthStats() Dim Stats As TMonthStats Dim StartDate As Date Dim EndDate As Date ' مثال: مارس 2025 كامل StartDate = DateSerial(2025, 3, 1) EndDate = DateSerial(2025, 3, 31) Stats = CalculateMonthStats(StartDate, EndDate, Month(StartDate), Year(StartDate)) ' طباعة النتائج Debug.Print "==============================" Debug.Print "اختبار CalculateMonthStats:" Debug.Print "الشهر: " & Stats.MonthName & " - " & Stats.CalendarYear Debug.Print "إجمالي الأيام: " & Stats.TotalDays Debug.Print "أيام الجمعة: " & Stats.FridayCount Debug.Print "أيام السبت: " & Stats.SaturdayCount Debug.Print "أيام العمل: " & Stats.WorkingDays Debug.Print "==============================" End Sub '================================================= ' دالة اختبار عدد أيام أي يوم من الأحد إلى الخميس '================================================= Public Sub TestCountWeekdaysOtherThanFriSat() Dim StartDate As Date Dim EndDate As Date Dim TargetDay As WeekDays Dim Count As Long ' مثال للفترة: من 1 مارس 2025 إلى 31 مارس 2025 StartDate = DateSerial(2025, 3, 1) EndDate = DateSerial(2025, 3, 31) Debug.Print "==============================" Debug.Print "اختبار CountWeekday للأيام غير الجمعة والسبت:" Debug.Print "الفترة من: " & FormatDateValue(StartDate) Debug.Print "إلى: " & FormatDateValue(EndDate) ' التجربة لجميع الأيام من الأحد إلى الخميس For TargetDay = wdSunday To wdThursday Count = CountWeekday(StartDate, EndDate, TargetDay) Debug.Print WeekdayName(TargetDay) & ": " & Count Next TargetDay Debug.Print "==============================" End Sub '================================================= ' دالة اختبار عدد أيام أي يوم من الأحد إلى الخميس (باستثناء الثلاثاء) '================================================= Public Sub TestCountWeekdaysExceptTuesday() Dim StartDate As Date Dim EndDate As Date Dim TargetDay As WeekDays Dim Count As Long ' الفترة الزمنية للاختبار StartDate = DateSerial(2025, 3, 1) EndDate = DateSerial(2025, 3, 31) Debug.Print "==============================" Debug.Print "اختبار CountWeekday للأيام الأحد-الإثنين-الأربعاء-الخميس (باستثناء الثلاثاء)" Debug.Print "الفترة من: " & FormatDateValue(StartDate) Debug.Print "إلى: " & FormatDateValue(EndDate) ' التجربة لجميع الأيام من الأحد إلى الخميس مع استثناء الثلاثاء For TargetDay = wdSunday To wdThursday If TargetDay <> wdTuesday Then Count = CountWeekday(StartDate, EndDate, TargetDay) Debug.Print WeekdayName(TargetDay) & ": " & Count End If Next TargetDay Debug.Print "==============================" End Sub اطيب الامانى

في ظل التفاعل المتواضع ، تم اعتماد الفكرة :- 2️⃣ إنشاء نظام تسجيل دخول احترافي برمجياً ، مع نظام صلاحيات متعدد المستويات .. للتطبيق والتنفيذ وطرحها في موضوع مستقل إن شاء الله . شكراً من القلب لكل من تفاعل ولكل من مر من هنا . سيتم الإعلان عن الفكرة والمطلوب تنفيذها وشروطها وجميع معطياتها في موضوع قريب منفصل

دى الاجابة اللى اوصى بيها حساب الجمعة والسبت(V3).accdb

ماشاء الله زادك الله علماً ورفع الله قدرك ورزقك الله الفردوس الأعلى من الجنة

السلام عليكم جرب الكود Sub تلوين_المكرر() Dim ws As Worksheet, rng As Range, cell As Range Dim dict As Object, lastRow As Long Dim r As Long, c As Long, key As String Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then lastRow = 5 Set rng = ws.Range("A5:J" & lastRow) rng.Interior.ColorIndex = xlNone Application.ScreenUpdating = False For r = 5 To lastRow For c = 1 To 10 Set cell = ws.Cells(r, c) If Not IsError(cell.Value) And Len(cell.Value) > 0 Then key = Trim(cell.Value) Set dict = CreateObject("Scripting.Dictionary") For Each c2 In ws.Range(ws.Cells(r, 1), ws.Cells(r, 10)) If c2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed: GoTo NextCell ' التحقق عموديًا dict.RemoveAll For Each r2 In ws.Range(ws.Cells(5, c), ws.Cells(lastRow, c)) If r2.Value = key Then dict(key) = dict(key) + 1 Next If dict(key) > 1 Then cell.Interior.Color = vbRed End If NextCell: Next c Next r Application.ScreenUpdating = True End Sub