حساب الفرق بين تاريخين بإستخدام VBA

[أبو سجده]

السلام عليكم ورحمة الله وبركاته

فى الملف المرفق ثلاثة دلات معرفة بإستخدام ال VBA لحساب الفرق بين تاريخين على هذا النحو

لحساب فرق عدد الأيام

Option Explicit

Function CalcAged(vDate1 As Date, vdate2 As Date) As String
Dim vMonths
Dim vDays
Dim vYears

    vMonths = DateDiff("m", vDate1, vdate2)
    vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    If vDays < 0 Then
        vMonths = vMonths - 1
        vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    End If
    vYears = vMonths \ 12
    vMonths = vMonths Mod 12
CalcAged = vDays
End Function

ولحساب فرق عدد الشهور

Function CalcAgem(vDate1 As Date, vdate2 As Date) As String
Dim vMonths
Dim vDays
Dim vYears

    vMonths = DateDiff("m", vDate1, vdate2)
    vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    If vDays < 0 Then
        vMonths = vMonths - 1
        vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    End If
    vYears = vMonths \ 12
    vMonths = vMonths Mod 12
CalcAgem = vMonths
End Function

ولحساب عدد السنوات

Function CalcAgey(vDate1 As Date, vdate2 As Date) As String
Dim vMonths
Dim vDays
Dim vYears

    vMonths = DateDiff("m", vDate1, vdate2)
    vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    If vDays < 0 Then
        vMonths = vMonths - 1
        vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2)
    End If
    vYears = vMonths \ 12
    vMonths = vMonths Mod 12
CalcAgey = vYears
End Function

المشكلة التى أواجهها هى عدم تمكنى من تعديل هذه الدالة لحساب عدد السنوات والشهور معا

فكيف يمكن تحقيق ذلك فربما يكون هناك ما أغفوا عنه ****** لذا نرجو مساهمة حضراتكم

مع الإطلاع على المرفق لمعرفة ما أعنيه ***** شكرا مقدما لحضراتكم وجزاكم الله خيرا

حساب الفرق بين تاريخين.xlsm

تم تعديل أكتوبر 11 بواسطه عبد الرحمن أشرف

[أبو سجده]

للرفع

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

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

لهدا سنقوم بدمج الدوال الخاصة بك في دالة واحدة مع بعض التعديلات للحصول على نفس النتائج الموجودة على   عمود k 

CalcAge  تحسب الفرق بين تاريخين (vDate1 و vDate2) بطريقة تقليدية  

CalcAgey2 تستخدم DateDiff

 

Option Explicit
Dim Cnt As Boolean
Function CalcAge(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant
    Dim vYears As Integer, vMonths As Integer, vDays As Integer

    If IsEmpty(vDate1) Or IsEmpty(vDate2) Then
        CalcAge = ""
        Exit Function
    End If

    If Not IsDate(vDate1) Or Not IsDate(vDate2) Then
        CalcAge = CVErr(xlErrValue)
        Exit Function
    End If

    If vDate2 < vDate1 Then
        If Not Cnt Then
            MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول"
            Cnt = True
        End If
        CalcAge = CVErr(xlErrValue)
        Exit Function
    End If
    Cnt = False

    ' حساب الفرق في السنوات والأشهر والأيام
    vYears = Year(vDate2) - Year(vDate1)
    vMonths = Month(vDate2) - Month(vDate1)
    vDays = Day(vDate2) - Day(vDate1)

    If vDays < 0 Then
        vMonths = vMonths - 1
        Dim lastMonth As Date
        lastMonth = DateAdd("m", -1, vDate2)
        vDays = Day(DateSerial(Year(lastMonth), Month(lastMonth) + 1, 1) - 1) + vDays
    End If

    If vMonths < 0 Then
        vYears = vYears - 1
        vMonths = vMonths + 12
    End If

    Select Case resultType
        Case "Days"
            CalcAge = vDays
        Case "Months"
            CalcAge = vMonths
        Case "Years"
            CalcAge = vYears
        Case "Days and Months"
            CalcAge = vDays & " Days and " & vMonths & " Months"
        Case "Years and Months"
            CalcAge = vYears & " Years and " & vMonths & " Months"
        Case "Total"
            CalcAge = vDays & ", " & vMonths & ", " & vYears
        Case Else
            CalcAge = "صيغة الدالة غير معروفة"
    End Select
End Function
Function CalcAgey2(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant
    If IsEmpty(vDate1) Or IsEmpty(vDate2) Then
        CalcAgey2 = ""
        Exit Function
    End If

    If Not IsDate(vDate1) Or Not IsDate(vDate2) Then
        CalcAgey2 = CVErr(xlErrValue)
        Exit Function
    End If

    ' حساب الفرق في الأشهر
    Dim totalMonths As Integer
    totalMonths = DateDiff("m", vDate1, vDate2)
    Dim vDays As Integer
    vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2)

    If vDays < 0 Then
        totalMonths = totalMonths - 1
        vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2)
    End If

    Dim vYears As Integer
    vYears = totalMonths \ 12
    Dim vMonths As Integer
    vMonths = totalMonths Mod 12

    Select Case resultType
        Case "Years"
            CalcAgey2 = vYears
        Case "Months"
            CalcAgey2 = totalMonths
        Case "Years and Months"
            CalcAgey2 = vYears & " Years and " & vMonths & " Months"
        Case "Days"
            Dim totalDays As Integer
            totalDays = DateDiff("d", vDate1, vDate2)
            CalcAgey2 = totalDays
        Case "Months and Days"
            CalcAgey2 = totalMonths & " Months and " & vDays & " Days"
        Case "Total"
            CalcAgey2 = vDays & ", " & vMonths & ", " & vYears
        Case Else
            CalcAgey2 = CVErr(xlErrValue)
    End Select
End Function

 

عدد الأيام
=CalcAge(A3, B3, "Days")

عدد الشهور
=CalcAge(A3, B3, "Months")

عدد السنوات
=CalcAge(A3, B3, "Years")

عدد الشهور الطريقة 2
=CalcAgey2(A3, B3, "Months")

حساب  السنوات والشهور 
=CalcAge(A3, B3, "Years and Months")

حساب الايام والشهور
=CalcAge(A3, B3, "Days and Months")

 

 

 

حساب الفرق بين تاريخين v1.xlsm

[أبو سجده]

والله رائع جدا جدا أخى الكريم الفاضل / محمد هشام

كود ولا أروع ***** بارك الله فيكم وجزاكم الله خيرا

[أبو سجده]

أخى وحبيبى فى الله محمد هشام

حاولت إضافة حالة أخرى للحصول على عدد الايام والشهور والسنوات

دون جدوى فهل من سبيل لتحقيق ذلك **** برجاء ملاحظة الخلية ذات اللون الرمادى ****** شكرا وجزاكم الله خيرا

حساب الفرق بين تاريخين - محمد هشام.xlsm

تم تعديل أكتوبر 17 بواسطه عبد الرحمن أشرف

[محمد هشام.]

جرب هل هدا ما تقصده 

 

حساب الفرق بين تاريخين - محمد هشام.xlsm

[أبو سجده]

نعم أخى محمد هذا ما أقصده

هناك نقطة أخيرة فى هذا الموضوع إن لم أكن مزعجاً ***** ولسنا فى عجلة من أمرنا

لأنه ربما تستغرق هذة النقطة الكثير من وقتكم الثمين لتعديلها 

تتمثل هذة النقطة فى كيف يمكن تغيير اللغة الإنجليزية إلى اللغة العربية

كما نقول باللغة العربية على سبيل المثال ومن اليمين إلى اليسار  5 سنوات و 3 شهور و 18 يوم

أو ربما يوجد كود لتفقيط عدد السنوات والشهور والأيام

كقولنا **** خمسة سنوات وثلاثة أشهر وثمانية عشر يوما

أم تعدو هذه النقطة حُلما لى **** أرجو الإفادة وإن لم يكن أخى وحبيبى فى الله محمد

فقد وفيت وكفيت وعشت وعاش المغرب الحبيب وعاشت مصر  الحبيبة

تم تعديل أكتوبر 17 بواسطه عبد الرحمن أشرف

[محمد هشام.]

23 دقائق مضت, عبد الرحمن أشرف said:

5 سنوات و 3 شهور و 18 يوم

بكل سرور اخي @عبد الرحمن أشرف  يكفي تعديل بسيط على الدالة 

 Select Case resultType
    Case "Days"
        CalcAge = vDays
    Case "Months"
        CalcAge = vMonths
    Case "Years"
        CalcAge = vYears
    Case "Days and Months"
        CalcAge = vMonths & " شهور و " & vDays & " يوم"
    Case "Years and Months"
        CalcAge = vYears & " سنوات و " & vMonths & " شهور"
 Case "Years, Months, Days"
    CalcAge = Trim(vYears & " سنوات و " & vMonths & " شهور و " & vDays & " يوم")
    Case Else
        CalcAge = "صيغة الدالة غير معروفة"
End Select

و التأكد من إعدادات المحاذاة للخلايا 

 

 

حساب الفرق بين تاريخين - بالعربية .xlsm

تم تعديل أكتوبر 17 بواسطه محمد هشام.

[أبو سجده]

أخى محمد قد لا تؤتى كلمات الشكر والثناء بقدرها أمام قدرك الكبير

ولكن ما أعظم أن أقول لكم أخى الحبيب المحترم

جزاكم الله تعالى عنا خير الجزاء

وشكرا جزيلا لوقتكم الطيب المبارك الذى أحتسبه

عند المولى العلى القدير فى ميزان حسناتكم

تقبل وافر التحية والتقدير 

تم تعديل أكتوبر 17 بواسطه عبد الرحمن أشرف

[محمد هشام.]

11 ساعات مضت, عبد الرحمن أشرف said:

أو ربما يوجد كود لتفقيط عدد السنوات والشهور والأيام

كقولنا **** خمسة سنوات وثلاثة أشهر وثمانية عشر يوما

أم تعدو هذه النقطة حُلما لى

ليس هناك مستحيل اخي @عبد الرحمن أشرف  يمكننا إظافة دالة جديدة مع الحفاظ على الأولى لتتمكن من إختيار ما يناسبك  

 

الدالة الجديدة مع التفقيط 

Option Explicit
Function CalcAgeArabic(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant
    Dim vYears As Integer, vMonths As Integer, vDays As Integer

    If IsEmpty(vDate1) Or IsEmpty(vDate2) Then
        CalcAgeArabic = ""
        Exit Function
    End If

    If Not IsDate(vDate1) Or Not IsDate(vDate2) Then
        CalcAgeArabic = CVErr(xlErrValue)
        Exit Function
    End If

    If vDate2 < vDate1 Then
        MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول"
        CalcAgeArabic = CVErr(xlErrValue)
        Exit Function
    End If

    vYears = Year(vDate2) - Year(vDate1)
    vMonths = Month(vDate2) - Month(vDate1)
    vDays = Day(vDate2) - Day(vDate1)

    If vDays < 0 Then
        vMonths = vMonths - 1
        Dim lastMonth As Date
        lastMonth = DateAdd("m", -1, vDate2)
        vDays = Day(DateSerial(Year(lastMonth), Month(lastMonth) + 1, 1) - 1) + vDays
    End If

    If vMonths < 0 Then
        vYears = vYears - 1
        vMonths = vMonths + 12
    End If

    Select Case resultType
        Case "Days"
            CalcAgeArabic = NumberToArabicWords(vDays) & " يوم"
        Case "Months"
            CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور"
        Case "Years"
            CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات"
        Case "Days and Months"
            CalcAgeArabic = NumberToArabicWords(vMonths) & " شهور و " & NumberToArabicWords(vDays) & " يوم"
        Case "Years and Months"
            CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور"
        Case "Years, Months, Days"
            CalcAgeArabic = NumberToArabicWords(vYears) & " سنوات و " & NumberToArabicWords(vMonths) & " شهور و " & _
                                                                      NumberToArabicWords(vDays) & " يوم"
        Case Else
            CalcAgeArabic = "صيغة الدالة غير معروفة"
    End Select
End Function

Function NumberToArabicWords(ByVal Number As Integer) As String
    Select Case Number
        Case 1: NumberToArabicWords = "واحد"
        Case 2: NumberToArabicWords = "اثنان"
        Case 3: NumberToArabicWords = "ثلاثة"
        Case 4: NumberToArabicWords = "أربعة"
        Case 5: NumberToArabicWords = "خمسة"
        Case 6: NumberToArabicWords = "ستة"
        Case 7: NumberToArabicWords = "سبعة"
        Case 8: NumberToArabicWords = "ثمانية"
        Case 9: NumberToArabicWords = "تسعة"
        Case 10: NumberToArabicWords = "عشرة"
        Case 11: NumberToArabicWords = "أحد عشر"
        Case 12: NumberToArabicWords = "اثنا عشر"
        Case 13: NumberToArabicWords = "ثلاثة عشر"
        Case 14: NumberToArabicWords = "أربعة عشر"
        Case 15: NumberToArabicWords = "خمسة عشر"
        Case 16: NumberToArabicWords = "ستة عشر"
        Case 17: NumberToArabicWords = "سبعة عشر"
        Case 18: NumberToArabicWords = "ثمانية عشر"
        Case 19: NumberToArabicWords = "تسعة عشر"
        Case 20: NumberToArabicWords = "عشرون"
        Case 21: NumberToArabicWords = "واحد وعشرون"
        Case 22: NumberToArabicWords = "اثنان وعشرون"
        Case 23: NumberToArabicWords = "ثلاثة وعشرون"
        Case 24: NumberToArabicWords = "أربعة وعشرون"
        Case 25: NumberToArabicWords = "خمسة وعشرون"
        Case 26: NumberToArabicWords = "ستة وعشرون"
        Case 27: NumberToArabicWords = "سبعة وعشرون"
        Case 28: NumberToArabicWords = "ثمانية وعشرون"
        Case 29: NumberToArabicWords = "تسعة وعشرون"
        Case 30: NumberToArabicWords = "ثلاثون"
        Case Else: NumberToArabicWords = CStr(Number)
    End Select
End Function

 

حساب الفرق بين تاريخين - بالتفقيط (1).xlsm

تم تعديل أكتوبر 17 بواسطه محمد هشام.

[أبو سجده]

الله أكبر وتحيا المغرب وتحيا مصر

نديها فنجاااااااان بن محوج

يعجز لسانى عن مدى شكرى وإمتنانى العميق لشخصكم الطيب 

تمت الإفادة بحول الله تعالى

بارك الله فيكم وفى والديكم وجزاكم الله خيرا