نجوم المشاركات

يمكنك تجربة هذه المعادلة =MID(A2,FIND("|AR|",A2)+4,100) بالتوفيق

تفضل اخي ربما هدا ما تقصده نفس الفكرة لاكن بطرق مختلفة يمكنك اختيار ما يناسيك Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value If ligne = 0 Then [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub '***********************او**************************** Sub test2() Dim WS As Worksheet: Set WS = ActiveSheet Dim F As Variant, Data As Range Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] Set Data = WS.Range("L19:Q51") If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub F = Application.Index(Data, Evaluate("Row(1:" & Data.Rows.Count & " )"), Array(1, 2, 3, 4, 5, 6)) lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If ligne = 0 Then WS.[U4].Resize(UBound(F, 1), UBound(F, 2)) = F Else WS.Range("U" & lastrow).Resize(UBound(F, 1), UBound(F, 2)) = F End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub '***********************او**************************** Sub test3() Dim WS As Worksheet: Set WS = ActiveSheet Dim lastrow As Long, ligne As Range, search As Range Set ligne = [U4]: Set search = [L19] Set Data = WS.Range("L19:L51,M19:M51,N19:N51,O19:O51,P19:P51,Q19:Q51") Tbl = Réf(Data) lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub If ligne = 0 Then [U4].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl Else WS.Range("U" & lastrow).Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub Function Réf(Data) K = Data.Rows.Count: Col = Data.Areas.Count Dim Tbl(): ReDim Tbl(1 To K, 1 To Col) For i = 1 To Col For J = 1 To K: Tbl(J, i) = Data.Areas(i)(J): Next J Next i Réf = Tbl End Function Book2.xls

بل سبب المشكلة التعديلات التي تمت على النموذج اما الكود فهو يعمل بشكل ممتاز وتمت كتابتة بناء على المعطيات في الموضوع السابق ولعرض بيانات في نموذج مفرد غير منضم

ادن اخي تفاصيل أخرى يجب ألا تفوتها اثناء تصميمك للملف عند إظهار نموذج مستخدم وإخفائه ، يبقى النمودج في الذاكرة ، إذا قمت بالعملية عدة مرات دون تنزيله ، فقد يكون لديك خطأ في تشبع الذاكرة ، و توقف البرنامج عن العمل ولهذا السبب من المهم استخدام الماكرو التالي: Sub Unload_Forms() Dim i As Long, Model As Object On Error Resume Next ' لنفترض انك لديك 100 يوزر على المصنف For i = 1 To 100 Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Unload Model Next On Error GoTo 0 End Sub اليك اخي الملف عليه 16 يوزرفورم للتجربة واختيار ما يناسبك بعد اظافة الاحتمالات الواردة اسفله : اولا في حالة كنت ترغب بتوحيد وقت الظهور والاخفاء على جميع النمادج يمكنك استخدام الكود التالي Sub Model_Show() Dim i As Long Dim Model As Object Login_screen.Show ' نمودج المقدمة Application.Wait Now + TimeValue("00:00:5") Unload Login_screen For i = 1 To 16 '<<<---- ' عدد النمادج المرغوب اظهارها' Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Application.Visible = False With Model Model.Show Model.Repaint Application.Wait Now + TimeValue("00:00:2") ' تحديد المدة Model.Hide End With Next ' افراغ الداكرة On Error Resume Next For i = 1 To 16 Set Model = CallByName(UserForms, "Add", VbMethod, "UserForm" & i) Unload Model Next Application.Visible = True End Sub الاحتمال رقم 2 وهو الارجح ربما لطلبك Option Explicit Sub View_User1() Application.Visible = False On Error Resume Next Login_screen.Show Application.Wait Now + TimeValue("00:00:12") Unload Login_screen '****************************** UserForm1.Show UserForm1.Repaint Application.Wait Now + TimeValue("00:00:5") Unload UserForm1 '****************************** '********* اتمم الكود بنفس الطريقة********* '****************************** UserForm16.Show UserForm16.Repaint Application.Wait Now + TimeValue("00:00:3") Unload UserForm16 Application.Visible = True End On Error GoTo 0 End Sub الاحتمال رقم 3 هو انك لا تريد تعديل الكود السابق ادن ما عليك هو جعل الكود بالطريقة التالية Option Explicit Sub View_User2() Application.Visible = False On Error Resume Next Login_screen.Show Application.Wait Now + TimeValue("00:00:5") Unload Login_screen '****************************** UserForm1.Show UserForm1.Repaint Application.Wait Now + TimeValue("00:00:3") UserForm1.Hide '*********اتمم الكود بنفس الطريقة********* ' افراغ الداكرة Call Unload_Forms Application.Visible = True End On Error GoTo 0 End Sub للانتقال بين النمادج قبل نهاية المدة يمكنك الظغط على زر {ESC} / Échap على ما اظن انه الان بين يديك جميع الاحتمالات الواردة لتتمكن من اتمام ملفك وغلق الموضوع بادن الله تجربة 3.rar

هذه محاولة للوصول للهدف بمعادلة طويلة شيئا ما وساعد في تقصيرها تغيير شكل جدول المواد =IFERROR( if(INDEX(Liste!E$6:E$140,MATCH($B9,Liste!$J$6:$J$524,0))=0,"", if(INDEX(Liste!E$6:E$140,MATCH($B9,Liste!$J$6:$J$524,0))=1,INDEX(timetable!$d$2:$o$11,MATCH(E$8,timetable!$b$2:$b$11,0),MATCH($C9,timetable!$d$1:$o$1,0)), if(INDEX(Liste!E$6:E$140,MATCH($B9,Liste!$J$6:$J$524,0))=2,INDEX(timetable!$d$2:$o$11,MATCH(E$8,timetable!$b$2:$b$11,0)+1,MATCH($C9,timetable!$d$1:$o$1,0)), INDEX(timetable!$d$2:$o$11,MATCH(E$8,timetable!$b$2:$b$11,0),MATCH($C9,timetable!$d$1:$o$1,0))&" و "&INDEX(timetable!$d$2:$o$11,MATCH(E$8,timetable!$b$2:$b$11,0)+1,MATCH($C9,timetable!$d$1:$o$1,0)) ))),"") مع ملاحظة تطابق القسم بجوار اسم الطالب مع الموجود في الجدول وضرورة ضبط أرقام الغياب حيث تم وضع غياب في مادة ثانية ولا يوجد في الجدول مادة في هذا الوقت بالتوفيق استعمال الزمن اختبارات.xlsx

يمكنك استعمال هذه المعادلة في الخلية D4 =IFERROR(IF(INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))="","",INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))),"") وهي تعني إذا كانت نتيجة البحث فراغ تكون الخلية فارغة وليست صفرا ويمكنك تعديل معادلة الخلية E4 بنفس الطريقة بالتوفيق

جزاك الله كل خير

Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet '<<<---- Worksheets("27-10-2023الى2-11-2023") 'اسم ورقة العمل Dim lastrow As Long, ligne As Range, search As Rang Set ligne = [U4] '<<<----' خلية اللصق Set search = [L19] '<<<-- اي القيمة التي تم جلبها من الخلية '<<<---اول تاريخ على الجدول ("A4") ' '("U")' تحديد اخر خلية بها بيانات من عمود lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 ' لمنع التكرار '*********************** '("U") 'التحقق من وجود نفس تاريخ المدفوعات مسبقا في عمود ' ' في حالة وجوده يتم ايقاف تنفيد الكود مع رسالة اشعار If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value ''<<<----'نطاق البيانات المرحلة If ligne = 0 Then ' '<<<----التحقق من عدم وجود قيمة في خلية اللصق ' U4'في حالة فراغها يتم لصق البيانات ابتداءا من الخلية [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else ' U ' في حالةوجودقيمة يتم لصق البيانات بعد اخر صف به بيانات من عمود Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub

شكرا لك أخي الكريم على هذا التوضيح الرائع ربي يحفظك

ارفقي النماذج (والتى ذات صله) كامله (او تشمل المعطيات كامله) وحددي المطلوب علشان نقدر نساعدك صح لكن ترفقي نموذج ناقص المعطيات اكيد قد تصل لك اجابه غير دقيقه بالنسبه لطلبك ممكن تنفذي ده باستعلام افضل وفى حدث عند التغير ياخذ البيانات من الفرعي للرئيسي غير ان النموذج مبني على ان ياخذ مصدر بياناته من النموذج الاخر الرئيسي (الشاشة الاولى) ف بالتالى طلبك متعارض لحل الاشكالية هو عمل نموذج مستقل بذاته ليس له دخل باى نموج اخر * اقصد النموذج الفرعي

حضرتك ما فهمتي كلامي المفترض ان الفورم هذا خاص بمريض واحد فقط لانه بيتم فتحه عن طريق فورم اخر رئيسي واذا اردتي الانتقال الى مريض اخر اذهبي الى الفورم الرئيسي وانتقلى الى المريض الاخر وارجعي افتح الفورم هذا اسهل لكي لكن اذا اردتي هذا النموذج له قائمة يبقى يكون مستقل بذاته

استاذه / صفي طلبك فى حد ذاته فيه تعارض لا يجوز ان تطلبي تقريب وتحديد تاريح ميلاد لان الاثنين معا لن يكون فيها دقه اذا اردتي تحويل تاريخ الميلاد الى عمر او تحويل العمر الى تاريخ ميلاد طلبك هنا هيكون مظبوط لكن ان تطلبي تحديد تاريخ الميلاد وتقريب العمر هنا هتظهر نتائج خطأ لاحظي الصوره التاليه فى اخر مشهد بعد ما جاب تاريخ الميلاد وقربت غير الدينا ولتحويل العمر الى تاريخ ميلاد هتحتاجي الدالة هذه Function CalcBdate(years As Integer, months As Integer, days As Integer) As Date CalcBdate = DateAdd("yyyy", -years, Date) CalcBdate = DateAdd("m", -months, CalcBdate) CalcBdate = DateAdd("d", -days, CalcBdate) End Function وايضا الصب هذا Sub TestCalcBirthdate() Dim years As Integer Dim months As Integer Dim days As Integer years = Me.Y.Value months = Me.M.Value days = Me.D.Value bdate = CalcBdate(years, months, days) End Sub age collect.rar.

وليه ينزل نسخه ويفرمت فى نظام وندوز بيشتغل من على الفلاشه مباشرتا زي اسطوانت هرنز الإصدار الاخير ينزلها ويدخل يعمل كل حاجه هو عاوزها

جزاك الله خير ده هو المطلوب فعلا شاكر جدا لحضرتك

حاول اخي قبل الغاء تثبيت نسخة الاوفيس من الجهاز تجربت إعادة تعيين Microsoft Excel إلى الإعدادات الافتراضية ربما تفيدك

نسيت حذفه سهواً في إحدى التجارب CDate هي دالة تستخدم لتحويل قيمة إلى نوع البيانات Date/Time. يمكن استخدامها لتحويل سلسلة نصية تحتوي على تاريخ أو وقت إلى قيمة تاريخ/وقت صالحة. الدالة IsDate تُستخدم لفحص ما إذا كانت قيمة معينة يمكن تفسيرها كتاريخ صالح أو لا. تقوم هذه الدالة بإرجاع قيمة منطقية (True أو False) تشير إلى ما إذا كانت القيمة قابلة للتفسير كتاريخ. وهنا مشاركة قد تفيدك بشكل أوسع حول الموضوع لأستاذ @محمد طاهر عرفه منقولاً عن الأخ أبو هاجر

تفضل أخي @عمرو المطري هذه المشاركة بسيطة حسب ما فهمت من مشاركتك ،، Check 1.accdb ولكن لي سؤال كنقطة لم افهمها ، إذا ( كانت القيمة لا تساوي "تم السداد" أو "سداد أعلى من المستحق" ) ، فما الحل ؟ تحقق من هدفك واعلمني بالنتيجة ، لأنه بناء على طلبك تم تنفيذ الكود . وإن اضطررت لتغيير الشروط أخبرنا وهذا مرفق آخر بتعديل بسيط في حال عدم توافر الشرط الأول الذي ذكرته أعلاه :- Check 2.accdb

جزاك الله خيراً أستاذ @Foksh

اعمل ضغط للملف واذا كان حجم البرنامج كبير اعمل نسخة أخرى واحذف جميع الجداول والنماذج والتقارير واحتفظ فقط بالمطلوب لحل المشكلة

ربما يفيدك عمل إصلاح للأوفيس repair من لوحة التحكم ثم الغاء تثبيت البرامج ثم تختار إصلاح وليس إلغاء تثبيت بالتوفيق

وهذه مشاركة مني بعد اذن اساتذتي الافاضل Database2.accdb

وهذه مشاركتي البسيطة .. Weekday.accdb

تم استخدام عمود مساعد لعمل الفلتر بدون معادلة مصفوفات بالتوفيق استعمال الزمن اختبارات.xlsx

ربما Option Explicit Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets Application.ScreenUpdating = False WS.Activate On Error Resume Next WS.Range("A8").Select ActiveSheet.ShowAllData Selection.End(xlDown).Select On Error GoTo 0 Next End Sub

الفاتح سعيد الحسن ..المشكلة عندك انت بنظام جهاز الكمبيوتر لديك فربما لديك ; بدلا من , فعليك بتغيير الفصلة العادية داخل المعادلة بالفاصلة المنقوطة =IF(AE4="";""; IF(AE4>30;if(COUNTIF($AE$4:AE4;">"&30)=1;25%;if(COUNTIF($AE$4:AE4;">"&30)=2;50%;if(COUNTIF($AE$4:AE4;">"&30)=3;75%;100%))); IF(AE4>15;if(COUNTIF($AE$4:AE4;">"&15)=1;10%;if(COUNTIF($AE$4:AE4;">"&15)=2;15%;if(COUNTIF($AE$4:AE4;">"&15)=3;25%;50%))); if(COUNTIF($AE$4:AE4;"<="&15)=1;5%;if(COUNTIF($AE$4:AE4;"<="&15)=2;10%;if(COUNTIF($AE$4:AE4;"<="&15)=3;20%;20%))) )))

حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية AE5 مع نسخها يسارا =IF(AE4="","", IF(AE4>30,if(COUNTIF($AE$4:AE4,">"&30)=1,25%,if(COUNTIF($AE$4:AE4,">"&30)=2,50%,if(COUNTIF($AE$4:AE4,">"&30)=3,75%,100%))), IF(AE4>15,if(COUNTIF($AE$4:AE4,">"&15)=1,10%,if(COUNTIF($AE$4:AE4,">"&15)=2,15%,if(COUNTIF($AE$4:AE4,">"&15)=3,25%,50%))), if(COUNTIF($AE$4:AE4,"<="&15)=1,5%,if(COUNTIF($AE$4:AE4,"<="&15)=2,10%,if(COUNTIF($AE$4:AE4,"<="&15)=3,20%,20%))) ))) مع تغيير تنسيق الخلايا لهذا الصف نسبة مئوية percentage بالتوفيق

تم عمل البرنامج بمعادلات الأكسل والتنسيق الشرطي وقواعد التحقق من الصحة ‏‏الجدول المدرسي.xlsx تعليمات الجدول المدرسي.zip

ما شاء الله زادك الله من فضله وبارك الله في عملك وهذا هدية مني لكم قمت بعمله ولم أنجز آخر شيت فيه لعدم حاجتي ولاستغنائي ببرنامج aSc TimeTables وبالتوفيق للجميع توزيع الحصص + الجدول.xlsm

السادة اعضاء المنتدى الأفاضل تم تزويد الملف بالاكواد ويعمل الحمد لله بطريقة جيدة أضعه هنا اذا اراد احد الاستفادة منه Pension2023.xlsm

الاطروحات السابقة تناولت فيها العديد من الافكار حول الاستفادة من الفورم التفاعلي وعناصر التحكم وصفات كل عنصر علي حدة احيانا المستخدم يكون محتاج شاشة كبيرة فيها العديد والعديد من عناصر التحكم مما يشكل حالة من عدم التركيز للشكل العام وكمية العناصر المعروضة في الوقت نفسه فكرة بسيطة تخلي الفورم نفسه يعرض لك يلي انت محتاجه وذلك عن طريق التحكم في خصائص عنصر التحكم نفسه الفكرة باختصار كانك شغال علي دوت نت او علي اي موقع تضغط علي تبويب معين يظهر لك عناصر التحكم الخاصة به وتتحكم فيه كما تشاء اسيبكم للتجربة وان شاء الله تكون فيها النفع ولا تنسونا بدعوة بظهر الغيب بصلاح الحال المثال المرفق علي بيانات الموظفين لا يحتوي الا علي اكواد الحركة الخاصة بالموضوع Create Drill Down Data Entry.xlsm

Generate PDF Dahy VBA Skills fun موضوعنا النهاردة موضوع شيق مدخل للدرس الثالث للفورم التفاعلي وفي نفس الوقت ها نتعرف فيه علي أدوات ها توفر الوقت والمجهود لشريحة كبيرة تستخدم قالب معين مثل الموارد البشرية لما ترسل طلبات التوظيف المالية لمطابقات كشوف الحساب للموردين واحنا داخلين علي موسم الجرد الختامي والبنوك او الشركات او المواقع التي ترسل رسائل دورية وما الي ذلك انا اخترت المثال علي شئون الموظفين وطلبات التوظيف وهانتعرف علي كيفية التعديل علي النموذج Word عن طريق الفورم عناصر الدرس ملف Templet word القالب المستخدم اداة Microsoft Outlook 16.0 Object Library أداة Microsoft Word 16.0 Object Library ونتعلم مع بعض VBA Dynamic Code وكيفية عمل ملف PDF وارساله بالايميل الشرح نقوم بإضافة الأدوات في الفيجوال كما يلي من Tools نختار References Microsoft Outlook 16.0 Object Library اضافة أداة Microsoft Word 16.0 Object Library تحديد مسار القالب كما يلي شفت + كليك يمين علي ملف الوورد ثم نختار Copy as Path حسب موقع الملف علي جهازك انا عندي في برتيشن F "\F:\GeneratePDF\Template_Contract.docx" تحديد مسار حفظ ملفات PDF الذي يحفظها البرنامج F:\Generate and Preview طبعا يلي مش عارف يغير في الكود يقوم بحفظ الملف المرفق علي برتيشين الFبعد فك الضغط مباشرة . ملف الورد يلي نستخدمه كقالب ولاحظ المسميات يلي انت ظللتها بالاصفر نفس مسميات الليبل ف الفورم وضعتها بين علامتي ##لانها بيانات متغيرة سيتم اضافاتها من الفورم لاحظ معي عند استدعاء الملف بالورد شاهد النتيجة البرنامج اضاف البيانات المظلله بشكل تلقائي الوظيفة الثانية للبرنامج اني ببعت الملف بالايميل من البرنامج لتوفير الوقت والوظيفة في حالة التقارير الدورية او النشرات او حسب استخدام الفرد الذي يحتاج ارسال عدد كبير في نفس الوقت مع ملاحظة انه بشكل تلقائي بياخد الايميل من الفورم ويضيف اسم الموضوع والمرفقات كما بالكود بشكل تلقائي طبعا الشرح موجز لاهم العناصر انا برفق مع الشرح مثال عملي منه للشرح ومنه نستفيد منه او من الافكار يلي فيه وبكون منتظر حد يسال عن اي شئ داخل الملف بصدر رحب لكن للاسف كعادتنا نحفظ في الارشيف علي اية حال الملف بالمرفقات واي استفسار لا تترد كلنا بنتعلم مع بعض شارك وتفاعل انت تسال وذلك يسال واخر يجيب وكلنا هانستفيد الدرس القادم ان شاء الله هاشرح الاكواد ونتعرف علي كود الحغظ والتعديل والبحث الديناميكي لضمان عمل الملف اتبع الشرح السابق في اضافة الادوات ومسار الملف وبالتوفيق للجميع ولا تنسونا من دعائكم بظهر الغيب بصلاح الحال GeneratePDF.rar

بسم الله الرحمن الرحيم مع بعض النهاردة هانتعلم الخدع البصرية في اليوزرفورم بطريقة بسيطة باستخدام Image Ctrl استخدمت مثال للشرح Dark Mood App Officana قم بتصميم الشكل بواسطة اي برنامج من برامج تحرير الصور او البوبوبينت بشرط ان تكون بنفس المقاسات مع اختلاف الالوان وفي اليوز نضيف Image Ctrl الملف بسيط ولا يحتوي الا اكواد الحركة للاداء معاينة الفورم https://youtu.be/VGL00cnLVF8 الملف بالمرفقات Dark Mood App Officana.xlsm وبالتوفيق للجميع

السلام عليكم ..أخي الكريم إن أصبت فبها ونعمت وإن أخطأت فالرجاء - من السادة الزملاء - المشاركة بعلمكم الزاخر... 1399540541_QrcodeWaleed.xlsb

بالتوفيق اخي الكريم

السلام عليكم دالة استخراج تاريخ الميلاد او النوع او المحافظة من الرقم القومي ثلاثة معطيات بدالة واحدة 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 بالنسبة لمعطيات المحافظات لم تستكمل بعد ويمكنك اضافة المحافظات المتبقية حسب ما شرحت بالكود خبور خير دالة استخلاص تاريخ الميلاد و النوع و المحافظة من الرقم القومي.rar

السلام عليكم ورحمة الله وبركاته إخواني الكرام .. لاحظت أن كل فترة يتم السؤال عن هذا الأمر .. هذا الموضوع يخص الأرقام القومية في مصر ، وقد تم تناول الموضوع أكثر من مرة .. واطلعت على أكثر من موضوع بهذا الشأن ، فما وجدت أفضل ولا أيسر ولا أخف من دالة الأستاذ الكبير / عبد الله باقشير ، دالة يسيرة وسهلة ، ويمكنك ببساطة استخراج كل المعلومات والبيانات التي تريدها من خلال هذه الدالة .. الشكر الكبير موصول للأستاذ الكبير والعالم الجليل عبد الله باقشير .. نرجو من الله أن يحفظه من كل سوء .. الدالة في محرر الأكواد بهذا الشكل : (للدخول على محرر الأكواد اضغط من لوحة المفاتيح Alt + F11) 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/مطروح", "23/الفيوم", "88/خارج الجمهورية", "11/دمياط", "04/السويس", "03/بورسعيد", "34/شمال سيناء", "35/جنوب سيناء", "32/الوادي الجديد", "31/البحر الأحمر") '============================================== 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 = "" 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 كل ما أضفته في الكود هو أكواد باقي المحافظات ، ليكتمل العمل ويستفيد منه الجميع بإذن الله أترككم مع الملف المرفق ، لتتعلموا منه طريقة استخراج البيانات.... دمتم في طاعة الله و السلام هو مسك الختام ID Information.rar