حساب العمر

Radwan0 · فبراير 4, 2021

السلام عليكم

ارجو مساعدتكم في كود لحساب العمر

على سبيل المثال تاريخ الميلاد 15/7/1991 وتاريخ اليوم 05/02/2021 يحسب لي العمر 29.5 على سبيل المثال

**محمد أبوعبدالله** · فبراير 5, 2021

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

ضع الكود التالي في وحدة نمطية جديدة

Option Compare Database

Public Function Diff2Dates(interval As String, Date1 As Date, Date2 As Date, Optional ShowZero As Boolean = False) As Variant

On Error GoTo Err_Diff2Dates

   Dim booCalcYears As Boolean
   Dim booCalcMonths As Boolean
   Dim booCalcDays As Boolean
   Dim booSwapped As Boolean
   Dim dtTemp As Date
   Dim intCounter As Integer
   Dim lngDiffYears As Long
   Dim lngDiffMonths As Long
   Dim lngDiffDays As Long
   Dim varTemp As Variant

   Const INTERVALs2 As String = "ddmmyyyy"
   interval = LCase$(interval)
   For intCounter = 1 To Len(interval)
      If InStr(1, INTERVALs2, Mid$(interval, intCounter, 1)) = 0 Then
         Exit Function
      End If
   Next intCounter

   If Not (IsDate(Date1)) Then Exit Function
   If Not (IsDate(Date2)) Then Exit Function

   If Date1 > Date2 Then
      dtTemp = Date1
      Date1 = Date2
      Date2 = dtTemp
      booSwapped = True
   End If

   Diff2Dates = Null
   varTemp = ""

   booCalcYears = (InStr(1, interval, "yyyy") > 0)
   booCalcMonths = (InStr(1, interval, "mm") > 0)
   booCalcDays = (InStr(1, interval, "dd") > 0)
   If booCalcYears Then
      lngDiffYears = Int(DateDiff("yyyy", Date1, Date2)) - IIf(Format$(Date1, "mm") <= Format$(Date2, "mm"), 0, 1)
      Date1 = DateAdd("yyyy", lngDiffYears, Date1)
   End If

   If booCalcMonths Then
      lngDiffMonths = Int(DateDiff("m", Date1, Date2)) - IIf(Format$(Date1, "dd") <= Format$(Date2, "dd"), 0, 1)
      Date1 = DateAdd("m", lngDiffMonths, Date1)
   End If

   If booCalcDays Then
      lngDiffDays = Int(DateDiff("d", Date1, Date2)) - IIf(Format$(Date1, "hh") <= Format$(Date2, "hh"), 0, 1)
      Date1 = DateAdd("d", lngDiffDays, Date1)
   End If


   If booCalcYears And (lngDiffYears > 0 Or ShowZero) Then
      varTemp = lngDiffYears & IIf(lngDiffYears <> 1, " سنه  ", " سنه  ")
   End If

   If booCalcMonths And (lngDiffMonths > 0 Or ShowZero) Then
      If booCalcMonths Then
         varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _
                   lngDiffMonths & IIf(lngDiffMonths <> 1, " شهر  ", " شهر  ")
      End If
   End If

   If booCalcDays And (lngDiffDays > 0 Or ShowZero) Then
      If booCalcDays Then
         varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _
                   lngDiffDays & IIf(lngDiffDays <> 1, " يوم", " يوم")
      End If
   End If

   If booSwapped Then
      varTemp = "-" & varTemp
   End If

   
   
   Diff2Dates = Trim$(varTemp)
End_Diff2Dates:
   Exit Function

Err_Diff2Dates:
   Resume End_Diff2Dates

End Function

وفي الاستعلام استخدم التالي

AGE: diff2dates("ddmmyyyy";[Fdate];[Ldate];True)

Fdate = التاريخ الاول = 15-07-1991

Ldate = التاريخ الثاني = 05-02-2021

تحياتي

**عبد اللطيف سلوم** · فبراير 5, 2021

تفضل برنامج جاهز

حساب العمر.accdb

Radwan0 · فبراير 5, 2021

10 ساعات مضت, محمد أبوعبدالله said:

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

ضع الكود التالي في وحدة نمطية جديدة


Option Compare Database

Public Function Diff2Dates(interval As String, Date1 As Date, Date2 As Date, Optional ShowZero As Boolean = False) As Variant

On Error GoTo Err_Diff2Dates

   Dim booCalcYears As Boolean
   Dim booCalcMonths As Boolean
   Dim booCalcDays As Boolean
   Dim booSwapped As Boolean
   Dim dtTemp As Date
   Dim intCounter As Integer
   Dim lngDiffYears As Long
   Dim lngDiffMonths As Long
   Dim lngDiffDays As Long
   Dim varTemp As Variant

   Const INTERVALs2 As String = "ddmmyyyy"
   interval = LCase$(interval)
   For intCounter = 1 To Len(interval)
      If InStr(1, INTERVALs2, Mid$(interval, intCounter, 1)) = 0 Then
         Exit Function
      End If
   Next intCounter

   If Not (IsDate(Date1)) Then Exit Function
   If Not (IsDate(Date2)) Then Exit Function

   If Date1 > Date2 Then
      dtTemp = Date1
      Date1 = Date2
      Date2 = dtTemp
      booSwapped = True
   End If

   Diff2Dates = Null
   varTemp = ""

   booCalcYears = (InStr(1, interval, "yyyy") > 0)
   booCalcMonths = (InStr(1, interval, "mm") > 0)
   booCalcDays = (InStr(1, interval, "dd") > 0)
   If booCalcYears Then
      lngDiffYears = Int(DateDiff("yyyy", Date1, Date2)) - IIf(Format$(Date1, "mm") <= Format$(Date2, "mm"), 0, 1)
      Date1 = DateAdd("yyyy", lngDiffYears, Date1)
   End If

   If booCalcMonths Then
      lngDiffMonths = Int(DateDiff("m", Date1, Date2)) - IIf(Format$(Date1, "dd") <= Format$(Date2, "dd"), 0, 1)
      Date1 = DateAdd("m", lngDiffMonths, Date1)
   End If

   If booCalcDays Then
      lngDiffDays = Int(DateDiff("d", Date1, Date2)) - IIf(Format$(Date1, "hh") <= Format$(Date2, "hh"), 0, 1)
      Date1 = DateAdd("d", lngDiffDays, Date1)
   End If


   If booCalcYears And (lngDiffYears > 0 Or ShowZero) Then
      varTemp = lngDiffYears & IIf(lngDiffYears <> 1, " سنه  ", " سنه  ")
   End If

   If booCalcMonths And (lngDiffMonths > 0 Or ShowZero) Then
      If booCalcMonths Then
         varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _
                   lngDiffMonths & IIf(lngDiffMonths <> 1, " شهر  ", " شهر  ")
      End If
   End If

   If booCalcDays And (lngDiffDays > 0 Or ShowZero) Then
      If booCalcDays Then
         varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _
                   lngDiffDays & IIf(lngDiffDays <> 1, " يوم", " يوم")
      End If
   End If

   If booSwapped Then
      varTemp = "-" & varTemp
   End If

   
   
   Diff2Dates = Trim$(varTemp)
End_Diff2Dates:
   Exit Function

Err_Diff2Dates:
   Resume End_Diff2Dates

End Function

وفي الاستعلام استخدم التالي


AGE: diff2dates("ddmmyyyy";[Fdate];[Ldate];True)

Fdate = التاريخ الاول = 15-07-1991

Ldate = التاريخ الثاني = 05-02-2021

تحياتي

الف الف شكر ياغالي فعلا هو المطلوب

ظهرت النتيجه كالتالي 29year 6monthe 21day

هل بالامكان ان تظهر 29.6 ؟؟

**محمد أبوعبدالله** · فبراير 5, 2021

42 دقائق مضت, RaDwAn00 said:

هل بالامكان ان تظهر 29.6

نعم يمكن اخي الكريم

قم بتعديل الوحدة النمطية كالتالي

Public Function Diff2Dates(interval As String, Date1 As Date, Date2 As Date, Optional ShowZero As Boolean = False) As Variant

On Error GoTo Err_Diff2Dates

   Dim booCalcYears As Boolean
   Dim booCalcMonths As Boolean
   Dim booCalcDays As Boolean
   Dim booSwapped As Boolean
   Dim dtTemp As Date
   Dim intCounter As Integer
   Dim lngDiffYears As Long
   Dim lngDiffMonths As Long
   Dim lngDiffDays As Long
   Dim varTemp As Variant

   Const INTERVALs2 As String = "ddmmyyyy"
   interval = LCase$(interval)
   For intCounter = 1 To Len(interval)
      If InStr(1, INTERVALs2, Mid$(interval, intCounter, 1)) = 0 Then
         Exit Function
      End If
   Next intCounter

   If Not (IsDate(Date1)) Then Exit Function
   If Not (IsDate(Date2)) Then Exit Function

   If Date1 > Date2 Then
      dtTemp = Date1
      Date1 = Date2
      Date2 = dtTemp
      booSwapped = True
   End If

   Diff2Dates = Null
   varTemp = ""

   booCalcYears = (InStr(1, interval, "yyyy") > 0)
   booCalcMonths = (InStr(1, interval, "mm") > 0)
   booCalcDays = (InStr(1, interval, "dd") > 0)
   If booCalcYears Then
      lngDiffYears = Int(DateDiff("yyyy", Date1, Date2)) - IIf(Format$(Date1, "mm") <= Format$(Date2, "mm"), 0, 1)
      Date1 = DateAdd("yyyy", lngDiffYears, Date1)
   End If

   If booCalcMonths Then
      lngDiffMonths = Int(DateDiff("m", Date1, Date2)) - IIf(Format$(Date1, "dd") <= Format$(Date2, "dd"), 0, 1)
      Date1 = DateAdd("m", lngDiffMonths, Date1)
   End If

   If booCalcDays Then
      lngDiffDays = Int(DateDiff("d", Date1, Date2)) - IIf(Format$(Date1, "hh") <= Format$(Date2, "hh"), 0, 1)
      Date1 = DateAdd("d", lngDiffDays, Date1)
   End If


   If booCalcYears And (lngDiffYears > 0 Or ShowZero) Then
      varTemp = lngDiffYears & IIf(lngDiffYears <> 1, ".", ".")
   End If

   If booCalcMonths And (lngDiffMonths > 0 Or ShowZero) Then
      If booCalcMonths Then
         varTemp = varTemp & IIf(IsNull(varTemp), Null, "") & _
                   lngDiffMonths & IIf(lngDiffMonths <> 1, "", "")
      End If
   End If

'   If booCalcDays And (lngDiffDays > 0 Or ShowZero) Then
'      If booCalcDays Then
'         varTemp = varTemp & IIf(IsNull(varTemp), Null, " ") & _
'                   lngDiffDays & IIf(lngDiffDays <> 1, " .", " .")
'      End If
'   End If

   If booSwapped Then
      varTemp = "-" & varTemp
   End If

   
   
   Diff2Dates = Trim$(varTemp)
End_Diff2Dates:
   Exit Function

Err_Diff2Dates:
   Resume End_Diff2Dates

End Function

تحياتي

Radwan0 · فبراير 5, 2021

مبدع ما شاء الله اخي الفاضل

سؤال اخير بعرف كثرت عليك غلبه هههه

نفرض بحال لم ادخل تاريخ الميلاد يظهر بالحقل #خطأ

المشكلة ان تاريخ الميلاد الان اعيد ادخاله وشكل الحقل به خطأ غير جميل

هل من حل لاخفاء هذه الكلمة

Hawiii · فبراير 5, 2021

حسب طلبك بسطر واحد يمكنك الحصول على المطلوب:

(ToDate - Birthdate + 1) / 365.2425

ويمكن استخدامه داخل دالة للعمر كالتالي:

Function CalAge(Birthdate As Variant, Optional ByVal ToDate As Date = -657434) As Double
  CalAge = -1
  If IsNull(Birthdate) Then Exit Function
  
  Birthdate = CDate(Birthdate)
  If ToDate = -657434 Then ToDate = Date
  If ToDate < Birthdate Then Exit Function
  
  CalAge = (ToDate - Birthdate + 1) / 365.2425
End Function

ويمكنك مناداة الدالة بإدخال تاريخ الميلاد فقط أو بالميلاد وتاريخ النهاية معا.

ملاحظة : كل دوال العمر التي تعطيك النتائج بالسنة والشهر واليوم الموجودة بأوفيسنا أو بالمنتديات الأجنبية وحتى مثال مايكروسوف أكسس لا تعطي نتائج 100% فلا تتعب نفسك في البحث والمقارنات وبنظري المتوفر مع أخطاءها البسيطة تفي بالغرض.

تم تعديل فبراير 5, 2021 بواسطه Hawiii

تسجيل الدخول

حساب العمر

الردود الموصى بها

Radwan0

رابط هذا التعليق

شارك

محمد أبوعبدالله

رابط هذا التعليق

شارك

عبد اللطيف سلوم

رابط هذا التعليق

شارك

Radwan0

رابط هذا التعليق

شارك

محمد أبوعبدالله

رابط هذا التعليق

شارك

Radwan0

رابط هذا التعليق

شارك

Hawiii

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information