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

In worksheet module Private Sub Worksheet_SelectionChange(ByVal Target As Range) Me.Unprotect If Target.Cells(1).Value = Empty Then Exit Sub Me.Protect End Sub

Try the same steps as we did with MSSTKPRP.DLL but with mscomctl.ocx mscomctl.zip Does the error message change or the same message exactly

جرب .... Dim db As DAO.Database Dim rs As DAO.Recordset Dim rs1 As DAO.Recordset Dim rs2 As DAO.Recordset Dim i, ii, e As Integer Dim str, str1, str2 As String str = "SELECT TBL_Rserve.IdEmployee, TBL_Rserve.Id_Day, TBL_Rserve.Period1, TBL_Rserve.Period2, TBL_Rserve.Period3, TBL_Rserve.Period4, TBL_Rserve.Period5, TBL_Rserve.Period6, TBL_Rserve.Period7, TBL_Rserve.Period8, TBL_Rserve.Id_Absence FROM TBL_Rserve WHERE (((TBL_Rserve.Id_Day)=" & Me.kan & ") AND ((TBL_Rserve.Id_Absence)=2));" str1 = "SELECT TBL_Rserve3.IdEmployee, TBL_Rserve3.Id_Day, TBL_Rserve3.Period, TBL_Rserve3.Id_Period FROM TBL_Rserve3;" str2 = "SELECT TBL_Rserve.IdEmployee, TBL_Rserve.Id_Day, TBL_Rserve.Period1, TBL_Rserve.Period2, TBL_Rserve.Period3, TBL_Rserve.Period4, TBL_Rserve.Period5, TBL_Rserve.Period6, TBL_Rserve.Period7, TBL_Rserve.Period8, TBL_Rserve.Id_Absence FROM TBL_Rserve WHERE (((TBL_Rserve.Id_Day)=" & Me.kan & ") AND ((TBL_Rserve.Id_Absence)=1));" Set db = CurrentDb Set rs = db.OpenRecordset(str) Set rs1 = db.OpenRecordset(str1) Set rs2 = db.OpenRecordset(str2) rs.MoveLast: rs.MoveFirst rs2.MoveLast: rs2.MoveFirst For ii = 1 To rs2.RecordCount For iii = 1 To rs.RecordCount For i = 0 To rs.Fields.Count - 4 If Len(rs.Fields(i + 2).Value & "") = 0 Then GoTo Next_i If Len(rs2.Fields(i + 2).Value & "") < 0 Then GoTo Next_ii rs1.AddNew rs1!IdEmployee = rs2.Fields(0).Value rs1!Id_Day = rs!Id_Day rs1!Id_Period = i + 1 rs1!Period = rs.Fields(i + 2).Value rs1.Update rs2.MoveNext Next_i: Next i rs.MoveNext i = i + 1 Next iii Next_ii: Next ii rs.Close Set rs = Nothing

بعد 5 ايام يتم الرد كلمة السر myPass Private Sub Worksheet_SelectionChange(ByVal Target As Range) Sheet1.Unprotect Password:="myPass" With Target .Cells.Locked = True On Error Resume Next .Cells.SpecialCells(xlCellTypeBlanks).Locked = False On Error GoTo 0 End With Sheet1.Protect Password:="myPass" End Sub 1مثال.xlsm

قم بفك هذه الاداة الى C:\Windows\System32 ثم شغلها من قائمة ابدا > نظام الويندوز > تشغيل Regsvr32.exe fm20.dll حتى يتم التسجيل وان لم ينجح عليك اظهار لنا قائمة العناصر المختارة من reference اغلب ظني ان هناك عنصر مختار يجب ازالته fm20.zip

Explain more details about the office version and the type of bit for the Office The same for your windows version and whether it is 32Bit or 64Bit Did you try to restart after the steps Try also installing this package Please restart your PC after installing the package If the problem is still there , record a video of the steps while you are applying the steps VisualBasic6-KB896559-v1-ENU.zip Another point, there is a button below each post that says "LIKE" if you like the posts

Close Excel application Download MSSTKPRP.zip file and extract the MSSTKPRP.DLL to these paths C:\Windows\System32 C:\Windows\SysWOW64 Open command prompt as administrator and type these commands cd C:\Windows\System32 regsvr32 MSSTKPRP.DLL cd C:\Windows\SysWOW64 regsvr32 MSSTKPRP.DLL You may need to restart your pc

السلام عليكم 🙂 المشكلة ليست في تصدير البيانات الى اكسل ، وانما الصعوبة في عمل مجاميع كل عمود في الاكسل ، وهناك طريقتين لعمل هذا: أ. تصدير البيانات والتعامل مع بيئة الاكسل (Excel Object) برمجيا ، ب. عمل مجاميع الاعمدة من الاكسس وتصديرها جاهزة للاكسل ، وانا اتبعت هذه الطريقة 🙂 عملت 4 طرق ، وانت تختار الافضل لك: . بسبب انه في الاستعلام export_selfa ممكن يكون عندك الاسم مكرر اكثر من مرة () ، فكان لازم نعمل استعلام المجاميع qry_Sum_export_selfa ، بحيث يجمع قيم الموظف في سجل واحد : . الطريقة 3. من هنا عملنا التقرير rpt_Sum_export_selfa والذي مصدر بياناته الاستعلام اعلاه ، وعملنا تجميع الاعمدة في التقرير: . الفكرة الاخرى ، ان نعمل مجموع الاعمدة في الاستعلام نفسه ، والطريقة اللي توصلت لها ، هي عمل استعلام مجاميع الاعمدة فقط qry_Sum_export_selfa_2 : . وتكون نتيجتها . ثم نعمل استعلام توحيد qry_Sum_export_selfa_3 فيه الاستعلام الاول qry_Sum_export_selfa والثاني qry_Sum_export_selfa_2 . فتصبح النتيجة . الطريقة 1. بتصدير الاستعلام qry_Sum_export_selfa_3 الى اكسل عن طريق الامر TransferSpreadsheet ، الطريقة 2. بتصدير الاستعلام qry_Sum_export_selfa_3 الى اكسل عن طريق الامر OutputTo ، الطريقة 4. عمل تقرير من الاستعلام qry_Sum_export_selfa_3 وتصدير التقرير الى اكسل عن طريق الامر OutputTo : . وهذه اكواد الطرق اعلاه: Private Sub cmd_Transffer_Query_Click() '1 Dim File_Name As String File_Name = CurrentProject.path & "\" & "تفصيل سلفة متنوعة" & Format(Date, "---DDDD-DD-mmmm-yyyy") & ".xlsx" DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_Sum_export_selfa_3", File_Name, True End Sub Private Sub cmd_Output_qry_Click() '2 Dim File_Name As String File_Name = CurrentProject.path & "\" & "تفصيل سلفة متنوعة" & Format(Date, "---DDDD-DD-mmmm-yyyy") & ".xls" DoCmd.OutputTo acOutputQuery, "qry_Sum_export_selfa_3", acFormatXLS, File_Name, True, , , acExportQualityPrint End Sub Private Sub cmd_Output_rpt_Click() '3 Dim File_Name As String File_Name = CurrentProject.path & "\" & "تفصيل سلفة متنوعة" & Format(Date, "---DDDD-DD-mmmm-yyyy") & ".xls" DoCmd.OutputTo acOutputReport, "rpt_Sum_export_selfa", acFormatXLS, File_Name End Sub Private Sub cmd_Output_rpt_3_Click() '4 Dim File_Name As String File_Name = CurrentProject.path & "\" & "تفصيل سلفة متنوعة" & Format(Date, "---DDDD-DD-mmmm-yyyy") & ".xls" DoCmd.OutputTo acOutputReport, "rpt_Sum_export_selfa_3", acFormatXLS, File_Name End Sub ونصيحة: انت مستعمل 160 حقل في الجدول FILE-1 ، ويجب عليك تفكيكه الى على الاقل 3 جداول ، وتربط بينهم برقم الموظف ، ثم في استعلام تجمعهم جميعا !! جعفر 1486.Database1 (2).accdb.zip

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

وعليكم السلام مشاركه مع الاستاذ @Moosak جزاه الله خيرا جرب الحل بالموضوع التالى لاخى العزيز @kanory جزاه الله خيرا بالتوفيق

فيديووووو جديددددد كيفية دمج عدة ملفات بهيدرز مختلفة في ملف واحد باستخدام الكويري في الفيديو دة هاتقدر تتدمج ملفات كثيرة في ملف واحد بس خلي بالك الملفات فيها اعمدة مختلفة >> يعني كل ملف في اعمدة مختلفة فا في الدرس ده هانتعلم نلم كل الاعمدة في ملف واحد https://youtu.be/2oXx8bt-1m0 جلب كل اسماء الاعمدة من الملفات.rar

انت اصبر دورك جاي🙂 في الواقع كتبت عدة اسطر في المشاركة السابقة ، بعدين اختصرتها في كلمتين 🙂 جعفر

السلام عليكم اخوي ابوخليل 🙂 الهدف من هذا الموضوع: 1. عند عمل المبرمج واجهة برنامجه FE ، فيحتاج الى عمل ربط لجداوله BE في جهازه ، 2. عند ارسال الواجهة للمستخدم ، فيجب ان يعمل البرنامج بدون تدخل المستخدم بإختيار مسار قاعدة البيانات ، 1. عند استلام المبرمج واجهة البرنامج للتعديل/الاضافة ، فيحتاج الى عمل ربط لجداوله BE في جهازه ، 2. عند ارجاع الواجهة للمستخدم ، فيجب ان يعمل البرنامج بدون تدخل المستخدم بإختيار مسار قاعدة البيانات. وهناك تشابه كبير بين طريقتي وطريقتك ، وهناك نقاط قوة وضعف في الطريقتين 🙂 جعفر

اعرض الملف برنامج متابعة ذوى الاحتياجات الخاصة برنامج مجانى تماما كامل لمتابعة ذوى الاحتياجات الخاصة والمهارات والأهداف التى يجب تجاوزها فى كل مرحلة والتى توضع حسب خطط منظمة ومتسلسلة ومتصلة يصلح لمراكز التأهيل وبه اسلوب ووضع خطط لكلاً من (مهارات التنمية - صعوبات التعلم - مهارات التخاطب - تأهيل وظيفى ...) ويمكن البرنامج من وضع جلسات وأعادتها ووضع تقارير عن كل شىء من الخطط والأهداف والجلسات والاخصائى وطرق البحث المكثفة والمتخصصة عن الحالات ووضع وتقييم الحالة وما تم من انجازات خلال تنفي> الخطط اللهم أكتب الشفاء لكل من أصابه ابتلاء واللهم أليك السؤال وفعلك ما شئت فأرحم عباداً يا من كتبت على نفسك الرحمة وأن الرحمن الدنيا والأخرة ورحيمهما نسألكم الدعاء أخوكم فى الله وليد الجمل سائلاً لله أن يجعله سبباً فى تحسين حالات أولادنا وأطفالنا ورحمة من الله لنا صاحب الملف walid7799 تمت الاضافه 10 مار, 2022 الاقسام قسم الأكسيس  

MSSTKPRP.zipThis is the DLL file

مشكور أخي الغالي وجزاك الله خير ، وجمعة مباركة علينا وعليكم إن شاء الله

=IF(A2>29;34;IF(A2>28;32;IF(A2>27;30;IF(A2>26;28;A2)))) السلام عليكم ورحمة الله وبركاته هذا فيما يخص الشق الأول من السؤال قم بإضافته بالخلية A3 ثم اسحب نحو بقية الخلايا أما فيما يخص الشق الثاني يرجى التعديل على الناتج مثلا =IF(A2>29;32.5;IF(A2>28;30.5;IF(A2>27;29.5;IF(A2>26;27.5;A2)))) تقبل تحياتي العطرة وإن كانت الإجابة كافية يرجى التفضل بتحديد أفضل إجابة لإتمام الموضوع والسلام عليكم

سؤال استاذ محمد لو سمحت ، إذا الفعلي 29 وعايز أخلي الناتج 32 وإذا 30 والناتج 34 دا بخصوص اليوم بيومين ..وأيضاً أحتاج من حضرتك دالة لو اليوم بيوم ونصف ممكن الطريقة لو تكرمت ولك جزيل الشكر والتقدير مقدماً حضور اليوم بيومين-١.xlsm

@Elsayeh هل لديك اصدارين اكسيل على نفس الجهاز ؟ قد يكون السبب منهم او من قائمة reference ابحث عن هذا الخيار كما في الصور اذا كان مختار ازل الخيار مجرد تخمين

وحضرتك والاسرة الكريمة بخير وسعادة وهناء ودائما فى طاعة الرحمن يا باش مهندس 🌹💕

وعليكم السلام تفيد الرسالة عن فئة غير مسجلة قد يكون الفيديو التالي مفيداً لك نقبل تحياتي.

جزاكم الله خيراً وأحسن إليكم يرجى التفضل بتحديد أفضل إجابة إن توصلت إلى نتيجة مرضبة والسلام عليكم

السلام عليكم أخي الكريم نتائج التصفية في صفحة ثانية حسب زر كل تصفية على حده تقبل تحياتي العطرة والسلام عليكم كود فلتر.xlsm

تفضل جرب هذا الملف رسائل واتس كصورة للنطاق1.xlsm

من عيونى يا باش مهندس شرح الاكواد بالوحدة النمطية تفصيلا اولا اسم الجدول ولانه سوف يتم استخدامه كثيرا ولاننى احببت تصعيب الامر قليلا استخدمت الـ Unicode Public Function tblUUID() tblUUID = Chrw("85") & Chrw("115") & Chrw("121") & Chrw("115") & Chrw("83") & Chrw("101") & Chrw("99") & Chrw("117") & Chrw("114") & Chrw("101") & Chrw("100") End Function فلو قمنا بقرائته فى نافذة immediate من خلال ?tblUUID() لتنتج لنا اسم الجدول UsysSecured كما فى الصورة الاتية 2- التأكد من وجود الجدول فى قاعدة البيانات من عدمه Public Function ifTableExists(tblName As String) As Boolean If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then ifTableExists = True End Function 3- السطر الاول انشاء الجدول من خلال استعلام السطر الثانى تشغيل الـ Function الاتى ChckUUID ,وسيتم شرحه لاحقا Public Function CrtTblUUID() DoCmd.RunSQL "CREATE TABLE " & tblUUID & "([ID] counter," & "[UUIDPC] text," & "[ApprovedNo] text," & "CONSTRAINT [Index1] PRIMARY KEY ([ID]));" ChckUUID End Function 4- التأكد من وجود قيم فى الجدول Public Function CountRec() As Boolean If DCount("*", tblUUID) = 1 Then CountRec = True End Function 5-التأكد من صلاحية مقتاح التسجيل الذى ارسلته لكم عند التجربة من خلال استخدام عدد 2 Function - ToGetAprv - GetUUID() وسيأتى شرحهم تباعا Public Function ChkApprovedNo() As Boolean If DLookup("ApprovedNo", tblUUID) = ToGetAprv(GetUUID()) Then ChkApprovedNo = True End Function ملاحظة عند الشرح الان وحدتنى قمت بعمل function باسم اخر لنفس الوظيفة وسوف اقوم بحذفه اسم ال function هو Public Function validat() As Boolean اعتذر على ذلك الخطأ 6- هذا ال Function للخثول على معرف فريد للجهاز يدعى UUID وببساطه هو هو اختصار للمعرف الفريد العالمي ، وهو معرف فريد يتم إنشاؤه آليًا ضمن نطاق معين يتم إنشاؤها بواسطة خوارزمية معينة تحدد المواصفات والعناصر بما في ذلك عنوان MAC لبطاقة الشبكة والطابع الزمني ومساحة الاسم (Namespace) والرقم العشوائي أو العشوائي الزائف والتوقيت والعناصر الأخرى وخوارزمية إنشاء UUID من هذه العناصر تعني الخصائص المعقدة لـ UUID أنه لا يمكن إنشاؤها إلا عن طريق الكمبيوتر مع ضمان تفردها Public Function GetUUID() Dim strComputer As String Dim objWMIService, colItems, objItem strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystemProduct", , 48) For Each objItem In colItems GetUUID = objItem.UUID Next End Function 7- اغلاق جميع النماذج المفتوحة ما عدا نموذج FrmNotReg ولعدم تسهيل الامر على العابثين تم استخدام الـ unicode فى كتابة اسم النموذج Public Function DoCloseForms() Dim F As Access.Form Dim i As Long For i = Forms.Count - 1 To 0 Step -1 Set F = Forms(i) If F.Name <> _ Chrw("70") & Chrw("114") & Chrw("109") & Chrw("78") & Chrw("111") & Chrw("116") & Chrw("82") & Chrw("101") & Chrw("103") _ Then DoCmd.Close acForm, F.Name End If Next i End Function فى النقطة رقم 5 فى الشرح قلت سوف يأتى لاحقا شرح الـ 2 function الاتى ذكر اسمائهم - ToGetAprv - GetUUID() GetUUID -- تم شرحة فى النقطة رقم 6 الـ ToGetAprv هو function يتم تمرير قيمة GetUUID() الجهاز الحالى اليه ليقوم بتحويله الى unicode يعنى من ظهر لهم هذا الرقم الخاص بالنسخة فى نموذج التسجيل 46364331-3536-4638-3344-4232FFFFFFFF طبعا كما سبق هذا هو معرف الـ UUID وبعد ان يتم تمريره الى الـ function ToGetAprv ليتم تحويله الى unicode المفروض انه يظهر على الشطل التالى ولكن قمت ببعض التعديلات على الكود الذى يقوم بالتجويل الى الـ unicode بحيث يتم الابقاء على الارقام فقط من دون Chw("") & ولذلك كانت النتيجة كالاتى 525451545251514945515351544552545156455151525245525051507070707070707070 ولذلك فان ال Public Function ChkApprovedNo() As Boolean If DLookup("ApprovedNo", tblUUID) = ToGetAprv(GetUUID()) Then ChkApprovedNo = True End Function يقوم بالوصول الى الرقم ذلك وان كان يساوى الرقم الذى يتم عمل لصق له فى نموذج التسجيل يتم فتح النموذج الرئيسي 8- الكود الاخير لاخر روتين فى الموديول يقوم بعمل كل ماسبق يتأكد من وجود الجدول لو مش موجود ينشئ الجدول ولو الجدول موجود يتأكد من عدد السجلات لو 0 سجل يتم انشاء سجل ويضع به رقم UUID فى الحقل الخاص به ولو السجلات تساوى 1 يقوم بالتأكد من قيمة رقم UUID ان كان المكتوب فى الجدول = الخاص بهذا الجاز يكمل باقى الخطوات والا يوقم بعمل تحديث له للرقم فى الحقل داخل الجدول بما يساوى رقم رقم UUID للجهاز وبعد ذلك يتم تحويل الـ رقم UUID الى unicode مع االبقاء على الرقام فقط ويتأكد من تلك القيمة فى الحقل الخاص بها للتأكد فان كانت يتم فتح النموذج الرئيسي والا يعود الى نموذج التسجيل ولذلك هذا هو المستخدم فى الحدث عند الفتح ويمكن وضعه بنموذج البدء بسهولة من خلال اسمه ChckUUID , او Call ChckUUID بس خلاص Public Function ChckUUID() If ifTableExists(tblUUID) Then Else: CrtTblUUID If DLookup("UUIDPC", tblUUID) <> GetUUID Then DoCmd.SetWarnings False: DoCmd.RunSQL "UPDATE UsysSecured SET UsysSecured.UUIDPC = GetUUID();": DoCmd.SetWarnings True DoEvents If CountRec() Then If DLookup("UUIDPC", tblUUID) = GetUUID Then If ChkApprovedNo Then _ DoCmd.Close acForm, _ Chrw("70") & Chrw("114") & Chrw("109") & Chrw("78") & Chrw("111") & Chrw("116") & Chrw("82") & Chrw("101") & Chrw("103") _ : DoCmd.OpenForm Chrw("70") & Chrw("114") & Chrw("109") & Chrw("77") & Chrw("97") & Chrw("105") & Chrw("110"), , , , , acDialog _ Else: DoCloseForms: DoCmd.OpenForm Chrw( _ "70") & Chrw("114") & Chrw("109") & Chrw("78") & Chrw("111") & Chrw("116") & Chrw("82") & Chrw("101") & Chrw("103"), , , , , acDialog Exit Function End If Else DoCmd.SetWarnings False: DoCmd.RunSQL "INSERT INTO UsysSecured ( UUIDPC ) SELECT GetUUID() AS UUID;": DoCmd.SetWarnings True End If End Function بس ممكن بدل الذهاب الى نموذج التسجيل اغلاق القاعدة نهائيا لمن يريد وطبعا للوصول للحماية القصوى وضع كلمة مرور على محرر الاكواد وكلمة سر لتشفير قاعدة البيانات عند الفتح واغلاق الشيفت واخفاء الاطار وعمل قاعدة ريموت لتمرر كلمة المرور الى القاعدة الحالية عند فتحها وطبعا تلك القاعدة سوف يتم تحويلها الى accde وهذا ما سوف اطرحه لاحقا بس الان انا متعب ملاحظة تم تعديل المرفق الرئيسي بالتعديل الأخير الذى تم تدارك الاخطاء به وسوف يتم حذف كل المرفقات بالموضوع تخفيفا على سيرفر المنتدى اجمل الامانى بكده ينتهى موضوع العبث ويتم تأمين القاعدة بأقصى درجات الأمان لمن يريد

تجربة اضافية برجاء فتح نموذج frmReadQR وعمل استعراض لرمز الاستجابة الذى تم انشاءه E-Invoicing.zip

السلام عليكم و رحمة الله و بركاتة الاخوة الكرام اعضاء المنتدى اقدم لكم برنامج بسيط من تنفيذى لادخال فواتير المبيعات و ترحيل البيانات الاساسية للفاتورة فى شيت و بيانات الاصناف فى شيت اخر يمكن ترحيل اكثر من صنف فى الفاتورة مع تكرار البيانات الاساسية فى شيت الاصناف اتمنى ان يستفيد الاخوة من البرنامج ملحوظة شيت Invoice محمى باسورد (1234) vba Invoice.xlsm

السلام عليكم ورحمة الله وبركاته إخواني الكرام .. لاحظت أن كل فترة يتم السؤال عن هذا الأمر .. هذا الموضوع يخص الأرقام القومية في مصر ، وقد تم تناول الموضوع أكثر من مرة .. واطلعت على أكثر من موضوع بهذا الشأن ، فما وجدت أفضل ولا أيسر ولا أخف من دالة الأستاذ الكبير / عبد الله باقشير ، دالة يسيرة وسهلة ، ويمكنك ببساطة استخراج كل المعلومات والبيانات التي تريدها من خلال هذه الدالة .. الشكر الكبير موصول للأستاذ الكبير والعالم الجليل عبد الله باقشير .. نرجو من الله أن يحفظه من كل سوء .. الدالة في محرر الأكواد بهذا الشكل : (للدخول على محرر الأكواد اضغط من لوحة المفاتيح 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

و إثراء الموضوع أيضا هذا حل بالمعادلات وهو لأحد الأخوة الأعضاء حساب السن و المحافظةو تاريخ الميلاد.rar

أعتقد أنه من الممكن عمل ذلك .. ولكن ما الداعي لعمل ذلك ؟ بالعكس أعتقد أن هذا أفضل ، بذلك تستغني عن ورقة العمل ، ويمكنك استخدام الكود في أي مصنف بدون الاضطرار إلى نسخ الجدول مع كل مصنف ستقوم باستخدام الكود فيه

بسم الله ما شاء الله جعله الله فى ميزان حسناتك مجهود عظيم ورائع لكن فى نقطه هنا لو افترضنا انى جبت اى ملف بنفس اسم قاعدة البيانات وعملت عمليت استبدال مش كده القاعده ضاعت ^_^