استخراج تاريخ الميلاد والنوع ومحافظة الميلاد من الرقم القومي Birth Date Gender Province UDF Function

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

أقدم لكم دالة معرفة User-Defined Function تقوم باستخراج تاريخ الميلاد والنوع ومحافظة الميلاد من الرقم القومي (لدولة مصر حيث الرقم القومي مكون من 14 رقم).

استخدام الدالة :

قم بوضع الدالة المعرفة في موديول عادي ثم انتقل لورقة العمل لكتابة المعادلات

بفرض أن الرقم القومي موجود في الخلية A2 ، قم بكتابة المعادلة التالية في الخلية B2 لاستخراج تاريخ الميلاد

=Kh_Date_Gender_Province(A2,1)

والمعادلة التالية لتحديد النوع (ذكر أو أنثى) ضعها في الخلية C2

=Kh_Date_Gender_Province(A2,2)

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

=Kh_Date_Gender_Province(A2,3)

وأخيراً إليكم الدالة المعرفة وتوضع كما ذكرنا في موديول عادي :

Function Kh_Date_Gender_Province(MyNumber As Variant, MyTest As Byte)
    Dim MyProvinces As Variant
    Dim R As Long
    Dim YY As String
    Dim TY As String * 1
    Dim D As String * 2, M As String * 2, Y As String * 2, X As String * 2, XX As String * 2
    
    MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية", "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة", "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط", "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح", "23/الفيوم", "88/خارج الجمهورية", "11/دمياط", "04/السويس", "03/بورسعيد", "34/شمال سيناء", "35/جنوب سيناء", "32/الوادي الجديد", "31/البحر الأحمر")
    
    D = Mid(MyNumber, 6, 2)
    M = Mid(MyNumber, 4, 2)
    Y = Mid(MyNumber, 2, 2)
    TY = Left(MyNumber, 1)
    
    Select Case TY
        Case "2": YY = "19" & Y
        Case "3": YY = "20" & Y
        Case Else
    End Select

    Kh_Date_Gender_Province = ""
    On Error GoTo 1
   
    If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Or Len(Trim(MyNumber)) = 0 _
    Or Val(M) < 1 Or Val(M) > 12 Or (Val(TY) <> 2 And Val(TY) <> 3) Or Month(DateSerial(YY, M, D)) <> Val(M) Then
            Kh_Date_Gender_Province = ""
            GoTo 1
    End If
    
    If MyTest = 1 Then
        If YY <> "" Then Kh_Date_Gender_Province = DateSerial(YY, M, D)
    ElseIf MyTest = 2 Then
        If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then YY = "ذكر" Else YY = "أنثى"
        Kh_Date_Gender_Province = YY
    ElseIf MyTest = 3 Then
        X = Mid(MyNumber, 8, 2)
        For R = LBound(MyProvinces) To UBound(MyProvinces)
            XX = MyProvinces(R)
            If X = XX Then
                Kh_Date_Gender_Province = Right(MyProvinces(R), Len(MyProvinces(R)) - 3)
                Exit For
            End If
        Next
    End If
1: End Function

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء