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

[Debug Ace]

في هذا الموضوع سنستعرض دالتين احترافيتين 

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

اطيب الامانى 

تم تعديل منذ 7 ساعات بواسطه Debug Ace