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

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

المفروض نعم ، وقد يكون بنفس المعادلة ايضا كما الاكسل   :)

جعفر

السلام عليكم

استاذى الكبير جعفر

بارك الله فيك

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

تطبيق الكود على ملفى

وتطبيق صلاحيات المستخدمين 

بارك الله فيك

رابط الملف

http://www.gulfup.com/?GGhWwy

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

بدون اي شرح للمطلوب ، كيف ممكن نساعدك؟؟

على العموم ، انا بحثت لك في المنتدي ، والغني بالامثلة مثل طلبك والاجابة عليها ، وهذا مثال:

/index.php/topic/225678-تجزئة-سلسلة-ارقام-علي-عدة-خانات/?p=1119732

جعفر

السلام عليكم

شرف كبير لى ردك للمره الثانية على موضوعى 

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

يتم استخراج بيانات 

تاريخ الميلاد

والنوع

والمحافظة

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

مع العلم ان الكود مصمم للاكسل

واريد نقله الى الاكسس

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

هل يمكن ذلك 

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

جربت الملف الخاص بك

ولكنه لا يرى ملف ويخبرنى ان الملف ليس ملف اكسس

بارك الله فيك

استاذى الفاضل 

الرابط فوق المتاذ

هوا ده طلبي واكثر ما تمنيت

بس توجد مشكله لم استطلع نقل المثالى وتطبيقه على ملفى 

هل يمكن المساعده

وعليكم السلام اخي :)

ارفق لنا اين المشكلة في محاولتك علشان نساعدك :)

جعفر

بارك الله فيك اخى الفاضل تم والحمد لله

بس بطريقه غريبه  :(  :( 

نقلت ملفى للملف :D  :D  :D  ههههههههههه بس نفعت معايا

بارك الله فيك

:)