مطلوب كود حساب السن يكون دقيق

[الاهلاوى 2007]

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

اتمنى المساعدة بكود حساب السن يكون دقيقة لاننى احتاجة بشدة

المطلوب فى زرقة ا وورقة 2

تقبلوا وافر الاحترام

المصنف1.xlsm

تم تعديل فبراير 10, 2019 بواسطه الاهلاوى 2007

[Ali Mohamed Ali]

وعليكم السلام

تفضل

 

المصنف1.xlsm

[العمراوى]

استاذ على شكرا على سرعة الاستجابة

لكن ياريت تلقى نظرة على الملف

وليكن او تاريخ سوف تجد اليوم 30 والمفروض والاصح هو 0وهكذا العشر تواريخ التى تليه

ولو عملنا معادلة للسن سوف يكون الناتج 0

الكود موجود فى ملفات سابقة بهذه الطريقة هل يوجد كود اصح

تم تعديل فبراير 10, 2019 بواسطه العمراوى

[Ali Mohamed Ali]

هذه محاولة ادق بالمعادلات

 

2.xlsm

[ابراهيم الحداد]

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

تم بفضل الله تصحيح الخطأ

Sub DatedIf_User()
Dim ws As Worksheet, Sh As Worksheet, Mh As Worksheet
Dim ShName As String, Rng As Range, C As Range
Dim LR As Long, VlDate As Variant
Application.ScreenUpdating = False
Set ws = Sheets("ورقة1")
VlDate = ws.Range("I5").Value
 '----------------------------------
LR = ws.Cells(Rows.Count, "E").End(xlUp).Row
If LR < 8 Then Exit Sub
ws.Range("I8:K" & LR + 1).ClearContents
Set Rng = ws.Range("H8:H" & LR)
 '----------------------------------
If IsEmpty(VlDate) = True Then
MsgBox "من فضلك ادخل تاريخ حساب السن"
Exit Sub
Else
On Error Resume Next
For Each C In Rng
If C.Value <> "" Then
YY = Year(VlDate)
y = Year(C.Value)
mm = Month(VlDate)
m = Month(C.Value)
dd = Day(VlDate)
D = Day(C.Value)
  '-----------------------
If D > dd And m > mm Then
C.Offset(0, 1) = dd + 30 - D
C.Offset(0, 2) = mm - m + 11
C.Offset(0, 3) = YY - y - 1

  '-----------------------

ElseIf D <= dd And m > mm Then
C.Offset(0, 1) = dd - D
C.Offset(0, 2) = mm - m + 12
C.Offset(0, 3) = YY - y - 1

  '-----------------------

ElseIf D > dd And m >= mm Then
C.Offset(0, 1) = dd - D + 30
C.Offset(0, 2) = mm - m + 11
C.Offset(0, 3) = YY - y - 1

  '-----------------------

ElseIf D > dd And m < mm Then
C.Offset(0, 1) = dd - D + 30
C.Offset(0, 2) = mm - m - 1
C.Offset(0, 3) = YY - y

  '-----------------------

Else
C.Offset(0, 1) = dd - D
C.Offset(0, 2) = mm - m
C.Offset(0, 3) = YY - y
End If
End If
Next
End If
Application.ScreenUpdating = True
End Sub

 

[Ali Mohamed Ali]

وعليكم السلام-احسنت استاذ ابراهيم عمل وكود ممتازان

جعله الله فى ميزان حسناتك

 

[ابراهيم الحداد]

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

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

بارك الله فيك و اشكرك على كلماتك الرقيقة و دعمك المستمر لجميع الاعضاء

 

 

[العمراوى]

الف شكر استاذ ابراهيم

جزاك الله كل خير

[الاهلاوى 2007]

جزاك الله كل خير تمام كده

شكرا لمجهودك استاذ ابراهيم

تقبل التحية والاحترام