طلب حل مشكلة حساب العمر

[الاهلاوى 2007]

الرجاء من الاستاذ الفاضل ابراهيم الحداد او احد المشرفين او من يستطيع

تعديل حساب العمر فاهلا بالمساعدة

ثانية تجارى.rar

[Ali Mohamed Ali]

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

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("بيانات الطالبات")
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

 

[العمراوى]

اولا الف شكر على الاهتمام والرد

لكن هذا كودخاص بالصف الاول ينقل البيانات من بيانات الطلبة الى الشيت لانه شيت واحد

اما هنا خمس شعب وليس شعبة واحدة والامتداد مختلف حاولت تغير الامتداد ولم تفح ممكن حضرتك تجرب

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

[العمراوى]

ياريت استاذ على تظبط الكود وتنشرة

[Ali Mohamed Ali]

 

.

 

ثانية.rar

[العمراوى]

استاذ على حضرتك نقلت نفس الملف بدون اى تعديل يعنى نفس المشكلة

[Ali Mohamed Ali]

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

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(ActiveSheet.Name)
VlDate = ws.Range("E2").Value
 '----------------------------------
LR = ws.Cells(Rows.Count, "C").End(xlUp).Row
ws.Range("F10:H" & LR + 1).ClearContents
Set Rng = ws.Range("E10:E" & 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

 

[العمراوى]

استاذ على ممكن حضرتك تجرب هذا التاريخ فى الملف اللى حضرت وضعته

1/12/2000 سوف يعطيك العمر بالسالب فى الشهور

وضعت الكود المنشور ولم يعمل

اعتذر للاطالة لكن نريد العمل يكون على اكمل وجه لاننا نحتاجة فى الكنترول

[احمد بدره]

بعد إذن أساتذنا الأفاضل تم التعديل

ثانية.rar

[Ali Mohamed Ali]

اخى الكريم يمكن تكون المشكلة لديك انت

فكما ترى بالصورة هذا من الملف المرسل اليك

 

.

 

[العمراوى]

الف شكر الحمد لله الملف استاذ على تمام

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

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

[الاهلاوى 2007]

الف شكر لكل من ساهم فى هذا العمل

بارك الله فيكم جميعا