دالة WORKDAY لحساب آخر يوم في العمل

[AbuuAhmed]

صممت دالة باسم myWorkDay شبيهة بدالة الاكسل WORKDAY لحساب آخر يوم في العمل وتحتاج إلى مدخلين أول يوم في العمل و عدد أيام عمل فعلي بدون العطل الاسبوعية.
جربوها فربما تنفعكم.
 

Option Explicit

Function myWorkDay(FmDate As Date, NetDays1 As Integer) As Date
    'WORKDAY شبيهة بدالة الاكسل
    'FmDate أول يوم عمل
    Dim Weekends As Integer
    Dim ToDate As Date
    Dim NetDays2 As Integer
    Dim LoopRepeat As Integer
    
    Weekends = Int(NetDays1 / 2.5)
    ToDate = FmDate + NetDays1 + Weekends - 1
    
    Weekends = CountWkDay(FmDate, ToDate, vbFriday) + _
               CountWkDay(FmDate, ToDate, vbSaturday)
    NetDays2 = ToDate - FmDate - Weekends + 1
    
    Do While NetDays1 <> NetDays2
        LoopRepeat = LoopRepeat + 1
        If LoopRepeat = 10 Then
            'Debug.Print "Looprepeat", LoopRepeat
            Exit Do
        End If
        
        If NetDays1 > NetDays2 Then
            NetDays2 = NetDays2 + 1
        Else
            NetDays2 = NetDays2 - 1
        End If
    
        ToDate = FmDate + NetDays2 + Weekends - 1
        Weekends = CountWkDay(FmDate, ToDate, vbFriday) + _
                   CountWkDay(FmDate, ToDate, vbSaturday)
        NetDays2 = ToDate - FmDate - Weekends + 1
    Loop

	If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1
	If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1
    
    myWorkDay = ToDate
End Function

Function CountWkDay(ByVal Date1 As Date, _
                    ByVal Date2 As Date, _
                    WkDay As VbDayOfWeek) As Long
    'WeekDay Counter
    Date1 = Date1 - 1
    Date1 = Fix((Date1 + (7 - WkDay)) / 7)
    Date2 = Fix((Date2 + (7 - WkDay)) / 7)
  
    CountWkDay = Date2 - Date1
End Function

يوجد مثال اكسل في هذه المشاركة:

 

تم تعديل أغسطس 5, 2023 بواسطه AbuuAhmed
التعديل في الكود

[AbuuAhmed]

تم التعديل على الدالة أعلاه بإضافة سطرين قبل نهاية الدالة.

[Moosak]

بارك الله فيك أبا أحمد @AbuuAhmed جهد مبارك وعمل مشكور 🙂

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

[AbuuAhmed]

2 ساعات مضت, Moosak said:

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

نعم استاذ موسى، هو التعديل الأخير بهذا الشأن وهي لا تحسبه كيوم عمل بل تحسبه من ضمن إجمالي المدة ولكن يبقى أيام العمل الفعلية صحيحة كالتالي:

والتعديل كان بإضافة هذين السطرين:

    If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1
    If Weekday(ToDate) >= vbFriday Then ToDate = ToDate - 1

الآن إذا هذه الدالة مطلوبة فعلا للأكسس وليس لها بديل سأقوم بتطويرها لتشبه تماما دالة الاكسل للإصدارات الحديثة بإضافة خيارات آخر الأسبوع واعتماد تاريخ البداية هو اليوم السابق للمدة الجديدة.
رأي الجميع مطلوب، وإلا تركناها كما هي.

التعديلات سوف تكون لقسم الأكسس دون قسم الاكسل.

 

 

 

[AbuuAhmed]

الدالة بعد الترقية:
 

تحت التطوير والتنقيح والفحص من جديد

دوال مساندة:
 

Function CountWkDay(ByVal Date1 As Date, _
                    ByVal Date2 As Date, _
                    WkDay As VbDayOfWeek) As Long
    'Weekend Days Counter
    Date1 = Date1 - 1
    Date1 = Fix((Date1 + (7 - WkDay)) / 7)
    Date2 = Fix((Date2 + (7 - WkDay)) / 7)
  
    CountWkDay = Date2 - Date1
End Function


Function myMod(ByVal Number As Double, ByVal Divisor As Double, _
            Optional NoZero As Boolean = False) As Double
    Dim Result As Variant
  
    If Divisor <> 0 Then
        Result = Number - Divisor * Int(Number / Divisor)
    Else
        Result = Number
    End If
  
    myMod = IIf(Result = 0 And NoZero, Divisor, Result)
End Function

من عنده اكسل اصدار حديث فليجرب هذه الدالة ويقارنها مع دالة الاكسل.

دالة الاكسل
 

تم تعديل أغسطس 6, 2023 بواسطه AbuuAhmed
تنقيح كود الدالة

[ابوخليل]

اضافة جميلة الى منتدى اوفيسنا

تظهر اهمية هذه الدالة لمن يبحث عنها وقت حاجته اليها ويجدها هنا .

كتب الله اجرك .

[Moosak]

6 ساعات مضت, AbuuAhmed said:

الدالة بعد الترقية

أستاذنا العزيز 🙂 

كأن الدالة تبدأ بحساب الأيام اعتبارا من اليوم التالي لليوم المختار .. أم أن هناك فكرة لم أستوعبها ؟

[AbuuAhmed]

18 دقائق مضت, Moosak said:

كأن الدالة تبدأ بحساب الأيام اعتبارا من اليوم التالي لليوم المختار .. أم أن هناك فكرة لم أستوعبها ؟

هي كذلك تماشيا مع الدالة الأصل في الاكسل، وهذه الملاحظة يمكنكم قراءتها في مشاركاتي السابقة صمن صورة مرفقة وفي أول سطر ضمن عنوان الملاحظات.
تاريخ البداية هو ليس أول يوم دوام بل آخر يوم في الفترة السابقة قبل الدوام.

[AbuuAhmed]

الدالة الآن أكثر مرونة، إذا أردناها كما الاكسل تماما يجب أن نجعل قيمة المدخل CompatibleWithExcel تساوي نعم True
وبترك هذا المدخل أو جعل قيمته لا False سوف تقوم الدالة بالتالي:
- اعتماد تاريخ البداية ضمن مدة العمل.
- اعتماد عطلة نهاية الأسبوع الجمعة والسبت.

الدالة بشكلها النهائي:
 

Function WORKDAY_INTL(ByVal StartDate As Date, _
                            NetDays As Integer, _
             Optional ByVal Weekend As Variant, _
             Optional ByVal CompatibleWithExcel As Boolean = False) As Date
    'WORKDAY.INTL شبيهة بدالة الاكسل
    Dim DayOfWeek1 As VbDayOfWeek
    Dim DayOfWeek2 As VbDayOfWeek
    Dim WkDays1 As Integer
    Dim WkDays2 As Integer
    Dim EndDate As Date
    Dim NetDays2 As Integer
    Dim DefWeekend As Byte
    Dim LoopRepeat As Integer
    
    '----------------------------------------------------
    If CompatibleWithExcel Then StartDate = StartDate + 1
    DefWeekend = IIf(CompatibleWithExcel, 1, 7)
    If IsMissing(Weekend) Then Weekend = DefWeekend
    If Not IsNumeric(Weekend) Then Weekend = DefWeekend
    If Weekend < 1 Or Weekend > 17 Then Weekend = DefWeekend
    If Weekend > 7 And Weekend < 11 Then Weekend = DefWeekend
    '----------------------------------------------------
                                   
    If Weekend <= 7 Then
        DayOfWeek1 = myMod(Weekend + 6, 7, True)
        DayOfWeek2 = myMod(DayOfWeek1 + 1, 7, True)
    Else
        DayOfWeek1 = Weekend - 10
        DayOfWeek2 = 0
    End If
    
    WkDays1 = Int(NetDays / IIf(Weekend <= 7, 2.5, 6))
    EndDate = StartDate + NetDays + WkDays1 + WkDays2 - 1
    
    WkDays2 = 0:         WkDays1 = CountWkDay(StartDate, EndDate, DayOfWeek1)
    If Weekend <= 7 Then WkDays2 = CountWkDay(StartDate, EndDate, DayOfWeek2)
    NetDays2 = EndDate - StartDate - WkDays1 - WkDays2 + 1
    
    Do While NetDays <> NetDays2
        LoopRepeat = LoopRepeat + 1: If LoopRepeat >= 10 Then Exit Do
        
        NetDays2 = NetDays2 + IIf(NetDays > NetDays2, 1, -1)
        EndDate = StartDate + NetDays2 + WkDays1 + WkDays2 - 1
                             
        WkDays2 = 0:         WkDays1 = CountWkDay(StartDate, EndDate, DayOfWeek1)
        If Weekend <= 7 Then WkDays2 = CountWkDay(StartDate, EndDate, DayOfWeek2)
        NetDays2 = EndDate - StartDate - WkDays1 - WkDays2 + 1
    Loop
    
    If Weekday(EndDate) = DayOfWeek1 Or Weekday(EndDate) = DayOfWeek2 Then EndDate = EndDate - 1
    If Weekday(EndDate) = DayOfWeek1 Or Weekday(EndDate) = DayOfWeek2 Then EndDate = EndDate - 1
    
    WORKDAY_INTL = EndDate
End Function                                   

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

ايام عمل_08.xlsm