استخراج تاريخ الميلاد من الرقم القومى

[احمد السيد سليمان]

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

المشكلة احتساب تاريخ الميلاد بشكل خطـ

Book20000000.xlsb

[Mohamedsherif]

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

Book20000000.xlsb

[احمد السيد سليمان]

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

واعتذر عن التأخير في الرد لظروف العمل 

ولكن كنت عاوز اعرف اليه مشكلة الكود ولماذا يعطى نتيجة خطأ

مرفق الملف بعد اجراء مقارنة بين الكود والمعادلة

Function Kh_MyDate(MyNumber As Variant) As Date
Dim D As String, M As String, Y As String, TY As String

    On Error GoTo Err_Kh_MyDate

    D = Mid(MyNumber, 6, 2)
    M = Mid(MyNumber, 4, 2)
    Y = Mid(MyNumber, 2, 2)
    TY = Left(MyNumber, 1)
    
    If TY = "2" Then Else Y = "20" & Y
     Kh_MyDate = DateSerial(Y, M, D)
    Exit Function

Err_Kh_MyDate:
     Kh_MyDate = 0
End Function

Book20000000.xlsb

[احمد السيد سليمان]

من اجل اثراء الموضوع تم ادخال تعديل على المعادلة يتعلق بمواليد 2000 وما بعدها

نحتاج اجراء هذا التعديل على الكود 

Book20000000.xlsb

[احمد السيد سليمان]

بالبحث في المنتدى والاطلاع على مشاركات الأعضاء في موضوعات متشابهة تم تعديل الكود لكى يعطي نتائج صحيحة على النحو التالي

Function Kh_MyDate(MyNumber As Variant) As Date
Dim D As String, M As String, Y As String, TY As String

    On Error GoTo Err_Kh_MyDate

    D = Mid(MyNumber, 6, 2)
    M = Mid(MyNumber, 4, 2)
    Y = Mid(MyNumber, 2, 2)
    TY = Left(MyNumber, 1)
    
    If TY = "2" Then Y = "19" & Y
    If TY = "3" Then Y = "20" & Y
    If TY = "4" Then Y = "30" & Y
     Kh_MyDate = DateSerial(Y, M, D)
    Exit Function

Err_Kh_MyDate:
     Kh_MyDate = 0
End Function

 

مرفق الملف بعد التعديل 

Book20000000.xlsb