مشكلة في كود contdate

[starsrays]

اسعد الله جميع اوقاتكم اخواني الكرام .. 

وجد في أحد مواضيع المنتدى المبارك كود لاحتساب المدد بين التواريخ الهجري وكان الكود يعمل بكفاءة عالية ولاحظت اليوم خلل في الاحتساب بحيث يزيد المدة شهر، 

مرفق لكم الكود ومثال على الامر على ملف اكسل .. 

Function ContDate(MyDate1 As Date, MyDate2 As Date, YMD As String)
D1 = Day(MyDate1): D2 = Day(MyDate2)
M1 = Month(MyDate1): M2 = Month(MyDate2)
Y1 = Year(MyDate1): Y2 = Year(MyDate2)
If D1 > D2 Then Dr = D2 + 30 - D1: M = -1 Else Dr = D2 - D1
If M1 > M2 Then Mr = M2 + M + 12 - M1: Y = -1 Else Mr = M2 - M1
Yr = Y2 - Y1 + Y
If YMD = "D" Or YMD = "d" Then ContDate = Dr
If YMD = "M" Or YMD = "m" Then ContDate = Mr
If YMD = "Y" Or YMD = "y" Then ContDate = Yr
End Function

شكرا لكم 

contdate.xlsm

[Ali Mohamed Ali]

تفضل هذه المعادلة

Option Explicit
Option Compare Text
Function kh_count_y_m_d(Mydate_Birth As Date, Optional Mydate_Now _
, Optional Y_M_D As String = "Y_M_D", Optional MyCalendar As Boolean)
Dim Mydate As Date, KH_Calendar As Integer
Dim D_1 As Integer, D_2 As Integer, M_1 As Integer, M_2 As Integer, Y_1 As Integer _
, Y_2 As Integer, D As Integer, M As Integer, Y As Integer
If IsDate(Mydate_Now) Then Mydate = Mydate_Now Else Mydate = Date
If IsDate(Mydate_Birth) And CDate(Mydate_Birth) <= CDate(Mydate) Then
    KH_Calendar = Calendar
    If MyCalendar = True Then Calendar = 1 Else Calendar = 0
    D_1 = Day(Mydate): D_2 = Day(Mydate_Birth)
    M_1 = Month(Mydate): M_2 = Month(Mydate_Birth)
    Y_1 = Year(Mydate): Y_2 = Year(Mydate_Birth)
    If D_1 >= D_2 Then D = D_1 - D_2: M = 0 Else D = D_1 + 30 - D_2: M = -1
    If M_1 + M >= M_2 Then M = M_1 + M - M_2: Y = 0 Else M = M_1 + M + 12 - M_2: Y = -1
    Y = Y_1 + Y - Y_2
    If Y_M_D <> "Y" Or Y_M_D <> "M" Or Y_M_D <> "D" Then kh_count_y_m_d = Y & "y-" & M & "m-" & D & "d"
    If Y_M_D = "Y" Then kh_count_y_m_d = Y
    If Y_M_D = "M" Then kh_count_y_m_d = M
    If Y_M_D = "D" Then kh_count_y_m_d = D
    Calendar = KH_Calendar
End If
End Function

 

kh_count.xlsm

[starsrays]

شكرا لك أخي الكريم تمت تجربة الكود ويعمل بكفاءة حتى الان