احضار بيانات الرقم القومى واسم الاب بواسطة الكود

[محمد قاسم 12]

طلب - احضار بيانات الرقم القومى واسم الاب بواسطة الكود

وارجوا احضارها حسبالتقسيمة فى الخلايا الموجود تحت اللون الاحمر

للرفع 2021.xlsx

[أ / محمد صالح]

هنا تجد ما يخص تاريخ الميلاد والنوع من الرقم القومي 

وبالنسبة لاسم ولي الأمر فهذا البيان يكتب يدويا أفضل 

نظرا لإشكالية عدم حصر الأسماء المركبة جميعها

بالتوفيق 

[محمد قاسم 12]

استاذي الفاضل 

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

بالفعل الكود موجود وقد جرت كود الاستاذ الفاضل @عبد الله بقاشير

ولكن المشكلة تكمن فى عدم قدرتى على تقسم عمود تاريخ الميلاد الى 3 اعمده يوم شهر سنه من خلال الكود

وهل يمكن السن فى 1/10 من خلال تطوير هذا الكود ايضا

 

Option Explicit

'           ÈÓã Çááå ÇáÑÍãä ÇáÑÍíã
'           ********************
'            ÏÇáÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÉ
'           Kh_Date_Sex_Province
'  ( ÇÓÊÎÑÇÌ ÊÇÑíÎ ÇáãíáÇÏ Çæ ÇáäæÚ (ÐßÑ - ÇäËì
'       Çæ ÇáãÍÇÝÙÉ ãä ÇáÑÞã ÇáÞæãí
'==============================================
'                  MyTest
'    ÇÐÇ ßÇäÊ = 1  ÊÞæã ÈÇÓÊÎÑÇÌ ÊÇÑíÎ ÇáãíáÇÏ
'          ÇÐÇ ßÇäÊ = 2  ÊÞæã ÈÇÓÊÎÑÇÌ ÇáäæÚ
'         ÇÐÇ ßÇäÊ = 3  ÊÞæã ÈÇÓÊÎÑÇÌ ÇáãÍÇÝÙÉ
'----------------------------------------------
'         MyProvinces  Ýí ãÊÛíÑ ÇáÌÏæá
'            ÇáÚãá áã  íÓÊßãá ÈÚÏ
'      íãßäß ÅÖÇÝÉ ÇáãÍÇÝÙÇÊ ÇáÇÎÑì ÇáÛíÑ ãæÌæÏÉ
'          Çæ ÊÚÏíá ÇáãæÌæÏ Ýí ÍÇáÇÊ ÇáÎØÃ
'   ÈäÝÓ ÇáØÑíÞÉ ÇáÑÞã ÇæáÇ Ëã "/" Ëã ÇÓã ÇáãÍÇÝÙÉ
'                             :  ãËÇá Úáì Ðáß
'               "01/ÇáÞÇåÑÉ"
'==============================================
'-----------------------------------------------------------------

Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte)
Dim MyProvinces As Variant
Dim r As Integer
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/ãØÑæÍ")
'==============================================
Kh_Date_Sex_Province = ""
On Error GoTo 1
If Len(Trim(MyNumber)) = 0 Then
    GoTo 1
End If

If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then
    Kh_Date_Sex_Province = "Error_MyNumber"
    GoTo 1
End If

If MyTest = 1 Then
    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 = y
        Case "3": yy = "20" & y
        Case Else: yy = ""
    End Select
    If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d)
    
ElseIf MyTest = 2 Then
    If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _
    yy = "ÐßÑ" Else yy = "ÇäËì"
    Kh_Date_Sex_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_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3)
            Exit For
        End If
    Next
End If
1:
End Function

 

[محمد قاسم 12]

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

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

واليكم الملف لعل احدم يستفيد منه

وخاصل الدعاء للاستاذ والعلامه الكبير

@عبدالله باقشير

للرفع 2021.xlsm

[أ / محمد صالح]

17 دقائق مضت, محمد قاسم 12 said:

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

 

شكرا لمجاملتك فقد تم الحل بعيدا عن توجيهاتي نهائيا

وزيادة في الخير

ربما يفيدك هذا الرابط

وهذا أيضا

ينبغي أن نتعلم ممن سبقنا في عمل ما نريد عمله

بالتوفيق