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

مساهمتي المتواضعة مع الأساتذة ، وتقصيراً لكود المهندس @ابو جودي ، Public Function FlexiBranchSerial(tableName As String, serialField As String, branchCode As String) As String On Error GoTo ErrorHandler If Trim(tableName & serialField & branchCode) = "" Then FlexiBranchSerial = "خطأ: مدخلات غير صالحة" Exit Function End If Dim db As DAO.Database Dim maxNum As Long Dim sql As String Dim qdf As QueryDef Set db = CurrentDb sql = "SELECT Max(Val(Left([" & serialField & "], InStr([" & serialField & "],'/') - 1))) AS MaxNum " & _ "FROM " & tableName & " WHERE [" & serialField & "] LIKE '*" & branchCode & "'" Set qdf = db.CreateQueryDef("", sql) maxNum = Nz(qdf.OpenRecordset()(0), 0) + 1 FlexiBranchSerial = Format(maxNum, "00") & "/" & branchCode Set qdf = Nothing Set db = Nothing Exit Function ErrorHandler: FlexiBranchSerial = "خطأ: فشل في توليد الرقم" End Function الإستدعاء :- Private Sub Specialty_AfterUpdate() DoctorID = FlexiBranchSerial("tblDoctors", "DoctorID", Specialty.Column(2)) End Sub ترقيم تلقائي حسب الفرع.accdb جميل جداً ، للخبرة دور في ترك أثر عظيم يدل على ركازة التفكير أبدعتم معلمنا الحبيب

السلام عليكم ورحمة الله وبركاته اولا ده كده كده هو احد اساتذة المنتدى العظماء الذين ادين لهم بكل الفضل بعد رب العزة سبحانه وتعالى فكل الشكر والتقدير والاحترام والإجلال والعرفان بالجميل لكل اساتذتنا العظماء بارك الله تعالى لنا فيهم وبارك لهم فى اعمارهم وعلمهم وعملهم وجعله فى موازين اعمالهم ان شاء الله علم ينتفع به وصدقة جارية شكر الله تعالى لهم حسن تحملهم لنا واسال الله تعالى ان يحسن اليهم كما يحسنون الينا والى كل طلاب العلم بدون كلل ولا ملل ... امين امين امين اشكرك جدا جزاكم الله خيـرا طيب طلما ان دماغك تاهت شويه صغيرين بس وناوى تفوق وتمشى خطوة خطوه تعالى نروح الملاهى وخليها تتوه اكثر عاوزك بقه تفهم الافكار الجديده فى التعديلات الأخيره فى المرفق الجديد هنا تم فصل كل منطق فى داله منفصله هذا افضل للصيانه وفى اضافة اى تعديلات فى خطوة محدده تم الاستغناء عن الحقول الغير منضمه مع النموذج المستمر وذلك حتى لا استخدم اى اكود فى حدث النموذج الحالى وذلك للحصول على اكبر قدر ممكن من السرعة فى الاداء والكفاءه عند معالجة البيانات وكذلك اقلل من اسطر استدعاء الاكواد عند الاستخدام ولذلك تم اضافة اجراءات جديده داخل الوحده النمطيه الجديد هنا : فصل تاريخ الميلاد وتوزيعه بشكل صحيح بطريقة اليه من خلال الرقم القومى انظر النتيجة داخل التقرير المنطق الذى احبه وابنى الكود بناء عليه هو التالى : لا يهمنى كم او عدد الاسطر داخل الوحدات النمطيه العامة بقدر المرونة والسهوله فى الاستدعاء والحصول على كل المتطلبات بقدر الامكان بقدر الامكان ان يكون الكود داخل الوحده النمطيه عام وشامل ليحقق العديد من الوظائف فى نفس الوقت دون التقييد النتيجه : فقط نقل الوحده النمطيه كما هى الى اى قاعدة بيانات ومراعاة طريقة الاستدعاء فقط للاكواد حسب الحاجه والحصول على العديد من النتائج حسب الرغبه بحسب طريقة الاستدعاء من نفس الجراءات والوظائف المستخدمه شغل فاخر من الاخر ودوال ذكيه بحق وحقيقى انت بس تفهمها وهى هتفهمك وتحقق احلامك - لذلك سوف تلاحظ ان الوحده النمطيه الان تقوم بعمل كل شئ الفصل لكل الارقام المختلفة التآمينى - المنشآة - الرقم القومى وتوزيع الاعداد بعد الفصل وكذلك استخراج وتوزيع تاريخ الميلاد من الرقم القومى ولو عاوز من الرقم القومى مكان الميلاد وكمان نوع الجنس : ذكر/انثى ممكن عمل ذلك فى التحديث القادم ان اردت مثل ما هو واضح من هذه الصورة يلا راجع وحلل وتتبع الاكواد ولو وقف معاك حاجه قول ------------------------------------ مرفق : التحديث الجديد فصل وتوزيع ارقام الرقم القومى 2.accdb

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات ذات مرة شاركت فى موضوع بخصوص فصل الرقم القومى وهذا هو الموضوع ولكن بصراحه انا معقد بطبعى ولا اهوى الحلول المعتادة والتى تستدعها اعدادها بشكل خاص فى كل مره ولذلك كتبت اجراء ذكي هههههههههه محدش يضحك 😡 شايفكم يوفر العديد من العناء والاستعلامات ووجع الراس ده غير المرونه والــ ...... ما تيجوا نشوف أحسن اولا : وحدة نمطيه عامة باسم : basDistributeNumeric الاكواد داخل الوحدة النمطيه هى : ' إجراء لفحص ما إذا كان النص يحتوي على أرقام فقط Function IsNumericOnly(ByVal InputString As String) As Boolean Dim i As Integer Dim char As String ' التحقق من أن السلسلة ليست فارغة If Len(InputString) = 0 Then IsNumericOnly = False Exit Function End If ' التحقق من أن كل حرف هو رقم فقط For i = 1 To Len(InputString) char = Mid(InputString, i, 1) If Not (char >= "0" And char <= "9") Then IsNumericOnly = False Exit Function End If Next i ' إذا كانت جميع الأحرف أرقام، ترجع True IsNumericOnly = True End Function الغرض : التأكد من ان القيمه التى سوف يتم تمريرها هى أرقام ثم الإجراء الرئيسي : لفصل الأرقام ' إجراء لفصل و توزيع القيم الرقمية اما فى متغير او عنصر تحكم مثل مربع نص Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, Optional MaxFields As Integer = 14, Optional ControlPrefix As String = "txt") Dim Index As Integer Dim ControlItem As Control Dim TextBoxCollection As Object ' Dictionary لتخزين مربعات النص Dim TargetTextBox As Control ' لتعريف كل مربع نص عند التكرار Dim NumericString As String Dim DictKey As Variant ' لتجنب مشاكل الفهارس عند التعامل مع Dictionary ' التحقق من نوع الإدخال ومعالجته If TypeName(InputValue) = "TextBox" Then If IsNull(InputValue.Value) Or Not IsNumericOnly(InputValue.Value) Then MsgBox "الإدخال غير صالح، يرجى إدخال أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue.Value ElseIf VarType(InputValue) = vbString Or VarType(InputValue) = vbVariant Then If Not IsNumericOnly(InputValue) Then MsgBox "الإدخال يجب أن يحتوي على أرقام فقط!", vbExclamation, "خطأ" Exit Sub End If NumericString = InputValue Else MsgBox "نوع الإدخال غير مدعوم، يرجى إدخال مربع نص أو قيمة رقمية نصية!", vbCritical, "خطأ" Exit Sub End If ' إنشاء قاموس لتخزين مربعات النص ذات البادئة المحددة فقط Set TextBoxCollection = CreateObject("Scripting.Dictionary") ' البحث عن مربعات النص المناسبة داخل النموذج أو التقرير If Not TargetObject Is Nothing Then For Each ControlItem In TargetObject.Controls ' التأكد من أن العنصر هو مربع نص ويمتلك البادئة المحددة If TypeName(ControlItem) = "TextBox" And Left(ControlItem.Name, Len(ControlPrefix)) = ControlPrefix Then Index = Val(Mid(ControlItem.Name, Len(ControlPrefix) + 1)) ' استخراج الرقم من اسم مربع النص If Index >= 1 And Index <= MaxFields Then TextBoxCollection.Add Index, ControlItem End If End If Next ControlItem End If ' مسح محتوى مربعات النص إذا كان هناك مربعات متاحة If TextBoxCollection.Count > 0 Then For Each DictKey In TextBoxCollection.Keys TextBoxCollection(DictKey).Value = "" ' مسح القيم Next DictKey End If ' التحقق من توفر عدد كافٍ من مربعات النص If TextBoxCollection.Count > 0 And TextBoxCollection.Count < Len(NumericString) Then MsgBox "عدد مربعات النص غير كافٍ لعرض كافة الأرقام!", vbExclamation, "خطأ" Exit Sub End If ' توزيع الأرقام على مربعات النص For Index = 1 To Len(NumericString) If Index > MaxFields Then Exit For If TextBoxCollection.Exists(Index) Then Set TargetTextBox = TextBoxCollection(Index) TargetTextBox.Value = Mid(NumericString, Index, 1) Else Call PrintDigitInfo(Index, ControlPrefix, NumericString) End If Next Index ' تنظيف المتغيرات Set TextBoxCollection = Nothing Set TargetTextBox = Nothing End Sub الغرض : الفصل والتوزيع تم كتابة الإجراء السابق بشكل احترافى ومرن ليمكن استدعاءه بتمرير معاملات اليه بكل مرونه الفوائد : ✔ مرونة فائقة : يمكن استدعاء الإجراء دون الحاجة إلى تمرير Target Object إذا لم يكن مطلوبا ✔ دعم إستخدام القيم بشكل مباشر : يمكن استخدامه فقط لمعالجة قيمة رقمية وطباعة النتيجة بدلا من الحاجة إلى نموذج أو تقرير ✔ دعم الاستخدام الأمثل لتعبئة القيم : يمكن استخدامه لمعالجة القيم أو تعبئة مربعات النص حسب الحاجة ✔ الاستدعاء مع نموذج أو تقرير >>--> تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام " يعنى مثلا مع الرقم القومى سوف استخدم عدد 14 مربع يبدأ بالبادئة : txtNatId ثم الرقم من 1 الى الرقم 14 " فى الاستدعاء التالى مثلا تحصل على فصل وتوزيع 14 أرقام Call BindTextBoxes(Me, "txtIns", 14, "txtNatId " أو ممكن بهذا الشكل فى هذه الحاله يتم استخدام الرقم الاختيارى المفضل ضمن الكود وهو 14 Call BindTextBoxes(Me, "txtIns", , "txtNatId " * وماذا لو كان هناك اكثر من رقم مثلما هو موجود فى الموضوع المشار إليه مثل الرقم التأمينى , كود المنشأه ونريد فصلهم بنفس الآليه وهذا هو ما دفعنى الى التفكير فى كتابة هذه الإجراءات الذكيه والتى يمكنها التعامل مباشرة بكل سهولة مع اى سلسلة رقميه مهما كان طولها أو اختلفت طيب لاعادة الاستدعاء مع امثلة أخري مثل الرقم التآمينى مثلا تحديد النموذج او التقرير الحالي من خلال استخدام : Me تمرير اسم العنصر الذى يحتوى على القيم الرقميه " اسم مربع النص" لو تم الاكتفاء بذلك سوف يقوم الإجراء بفصل عدد 14 رقم وهو المستخدم فى الكود اختياريا أو يمكن تمرير عدد الارقام الذى تريده حسب الحاجة و هنا قمة المتعة والمرونه سوف نستخدم مثلا 10 أرقام ثم بعد ذلك تمرر البادئه الخاصة باسماء مربعات النص التى تسبق الارقام مثلا مع الرقم التآمينى سوف استخدم عدد 10 مربع يبدأ بالبادئة : txtIns ثم الرقم من 1 الى الرقم 10" Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") وهكذا حسب الحاجة وحسب الرغبه * اذا أردانا التجربة للطباعة داخل النافذة الفورية على سبيل التجربة ' لتجربة طباعة النتيجة مباشرة في النافذة الفورية Private Sub PrintDigitInfo(Index As Integer, ControlPrefix As String, NumericString As String) Debug.Print "Digit Index " & Format(Index, "00") & " is : >>-> " & ControlPrefix & " " & Mid(NumericString, Index, 1) End Sub ونكتب مباشرة فى النافذة الفورية على سبيل المثال : DistributeNumericInput , "9876543210",5,"" سوف نحصل منها على النتيجة التاليه لفصل الارقام الخمسة الاولى Digit Index 01 is : >>-> 9 Digit Index 02 is : >>-> 8 Digit Index 03 is : >>-> 7 Digit Index 04 is : >>-> 6 Digit Index 05 is : >>-> 5 - طيب لنفترض اناا نريد تنفيذ عملية الفصل والتوزيع فى نموذج مستمر : برضو كتبت لكم إجراء ذكى لعمل استعلام ديناميكى الكود فى الوحدة النمطيه ' إجراء لإنشاء استعلام ديناميكي بناءً على الحقول المدخلة Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String Dim sqlQuery As String Dim i As Integer Dim fieldName As String Dim maxDigits As Integer Dim fieldPrefix As String Dim fieldInfo As Variant ' بدء بناء جملة SQL sqlQuery = "SELECT " & tableName & ".*, " ' معالجة كل حقل مطلوب مع عدد الأرقام والبادئة الخاصة به For Each fieldInfo In RequiredFieldsDistribute fieldName = fieldInfo(0) ' اسم الحقل maxDigits = fieldInfo(1) ' عدد الأرقام المطلوب توزيعها fieldPrefix = fieldInfo(2) ' البادئة المخصصة للحقول ' إنشاء الحقول المحسوبة لكل رقم في الحقل المطلوب مع البادئة For i = 1 To maxDigits sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & i & ", Null, Mid([" & fieldName & "], " & i & ", 1)) AS " & fieldPrefix & i & ", " Next i Next fieldInfo ' إزالة الفاصلة الأخيرة لإكمال الجملة بشكل صحيح sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2) ' إضافة جملة FROM sqlQuery = sqlQuery & " FROM " & tableName & ";" ' إرجاع جملة SQL النهائية GenerateDynamicSQL = sqlQuery End Function الغرض : عمل استعلام ديناميكى بكل سهولة ليكون مصدر بيانات للنموذج المستمر الفوائد : ✔ مرونة فائقة : تمرير اسم الجدول الذى يحتوى على حقل/حقول الأرقام المراد فصلها وتوزيعها ✔ مرونة فائقة : تمرير اسم (الحقل/حقول) للأرقام وذلك من خلال مصفوفة وفق الإجراء السابق الكود فى الوحدة النمطيه : ' إجراء للتحقق من وجود عنصر التحكم في النموذج Private Function ControlExists(frm As Form, ctrlName As String) As Boolean On Error Resume Next ControlExists = Not (frm.Controls(ctrlName) Is Nothing) On Error GoTo 0 End Function ' إجراء لربط مربعات النص بحقول البيانات تلقائيًا Sub BindTextBoxes(frm As Form, prefix As String, maxDigits As Integer) Dim i As Integer Dim ctrlName As String ' تعيين الحقول بناءً على العدد الصحيح لكل نوع For i = 1 To maxDigits ctrlName = prefix & i ' التحقق من وجود العنصر قبل تعيين ControlSource If ControlExists(frm, ctrlName) Then frm.Controls(ctrlName).ControlSource = ctrlName ' الحقل مرتبط مباشرة بالاستعلام End If Next i End Sub الفوائد : التأكد من وجود عناصر التحكم اللازمة أجراء لربط الحقول مع العناصر الخاصة بناء على الفصل وذلك لعملية التوزيع وبعد ذلك نقوم بعمل النموذج المستمر ونضع فيه العناصر اللازمة مع ضبط التسميات وفق الكود التى ونستدعى الإجراء السابق فى حدث الفتح للنموذج المستمر لتعين مصدر بيانات النموذج وفق الاستعلام الديناميكى داخل الإجراء الكود فى النموذج المستمر Private Sub Form_Open(Cancel As Integer) ' تعريف متغير لتخزين جملة SQL Dim sqlStatement As String ' إنشاء استعلام SQL ديناميكي لجلب البيانات المطلوبة مع توزيع الأرقام في الحقول sqlStatement = GenerateDynamicSQL("tblEmployees", _ Array("NationalID", 14, "txtNatId"), _ Array("InsuranceID", 10, "txtIns"), _ Array("OrganizationID", 10, "txtOrg")) ' تعيين جملة SQL كمصدر بيانات للنموذج Me.RecordSource = sqlStatement ' إعادة تحميل البيانات بعد تحديث مصدر السجلات Me.Requery End Sub - طبعا عند تغير الاسماء داخل الكود لابد من مطابقتها بالاسماء للعناصر داخل النموذج أو العكس الخطوة التاليه وهى توزيع الارقام التى تم فصلها على مربعات النص الغير منضمه اعتمادا على مصدر البيانات الذى تم انشائه بشكل آالى عند فتح النموذج ويتم ذلك من خلال الستدعاء التالى فى النموذج الكود داخل النموذج فى الحدث الحالى Private Sub Form_Current() ' ربط مربعات النصوص ببيانات الهوية القومية (14 خانة) Call BindTextBoxes(Me, "txtNatId", 14) ' ربط مربعات النصوص ببيانات الرقم التأميني (10 خانات) Call BindTextBoxes(Me, "txtIns", 10) ' ربط مربعات النصوص ببيانات كود المنشأة (10 خانات) Call BindTextBoxes(Me, "txtOrg", 10) End Sub بذلك نضمن فصل وتوزيع الارقام بشكل آلى * طيب الان لو أردنا عمل الفصل والتوزيع داخل تقرير : فى تصميم التقرير نقوم بالاعلان عن المتغيرات التاليه ' تعريف متغيرات لتخزين القيم النصية للأرقام Dim lngNationalID As String Dim lngInsuranceID As String Dim lngOrganizationID As String نقوم بعد ذلك باستدعاء إجراء الفصل والتوزيع حسب مكان مربعات النص اما فى منطقة الرأس أو التفصيل أو ذيل النموذج وفى حدث التنسيق لكل منطقة حسب تواجد المربعات الغير منضمه بها باستدعاء الأجراء بالشكل المباشر الكود داخل التقرير : Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم القومي If Not IsNull(Me!txtNationalID) Then lngNationalID = Trim(Me!txtNationalID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngNationalID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بالرقم التأميني If Not IsNull(Me!txtInsuranceID) Then lngInsuranceID = Trim(Me!txtInsuranceID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngInsuranceID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم القومي Call DistributeNumericInput(Me, lngNationalID, 14, "txtNatId") ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بالرقم التأميني Call DistributeNumericInput(Me, lngInsuranceID, 10, "txtIns") End Sub Private Sub PageHeaderSection_Format(Cancel As Integer, FormatCount As Integer) ' تحديث القيم بناءً على السجل الحالي لمربع النص المرتبط بكود المنشأة If Not IsNull(Me!txtOrganizationID) Then lngOrganizationID = Trim(Me!txtOrganizationID) ' إزالة المسافات الفارغة من بداية ونهاية النص Else lngOrganizationID = "" ' تعيين قيمة فارغة في حالة عدم وجود بيانات End If ' استدعاء الدالة لتوزيع الأرقام على مربعات النصوص المرتبطة بكود المنشأة Call DistributeNumericInput(Me, lngOrganizationID, 10, "txtOrg") End Sub --------------------------------------------- صورة توضيحيه من نموذج مفرد --------------------------------------------- صورة توضيحية من نموذج مستمر --------------------------------------------- صورة توضيحية من تقرير واخيــــرا المرفق أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع فصل و توزيع ارقام الرقم القومى.zip

في الكود الأخير لي ، لا أعتقد أنه يوجد نهاية للترقيم ❗ من -2,147,483,648 إلى 2,147,483,647 Dim maxNum As Long

الان بعد ان تمت الاجابة بشكل عملي اجمالا وتفصيلا انا لى بعض التعقيبات البسيطه انا افضل ان كان هناك جزء ثابت يكون فى الجهة اليسرى وليس فى الجهة اليمنى <<---< هذا افضل من وجهة نظرى انا لا افضل استخدام التسيق الذى يحدد عد منازل الترقيم لانه مثلا لو افترضنا انه تم التعامل على ان عدد منازل الترقيم سوف يكون 6 وبما أننا تحدثنا سابقا ان DMax تستخدم لاسترجاع أكبر قيمة في حقل معين سواء كان رقميا أو نصيا مع معالجة إضافية لاستخراج الجزء الرقمي لو لم تتم المعالجة بشكل صحيح عندما يكون الحقل نصيا بعد الوصول الى الحد النهائى للترقيم سوف يتوقف الكود عن العمل دعونا نشرح النقطة الثانية باستفاضه لنفترض ان الثابت فى الشق الايسر هو : ABC/ ثم بعد ذلك يأتى الترقيم والمكون من 6 منازل سوف يكون الترقيم بالشكل التالى تمام ABC/000001 ABC/000002 ABC/000003 ABC/000004 ABC/000005 ABC/000006 ABC/000007 ABC/000097 ولنفترض انه تم حذف سجلات والتى تبدأ من الرقم 8 الى الى الرقم 97 سوف يكمل بالشكل التالى بدون مشاكل ABC/000098 ABC/000099 ABC/000100 ABC/000101 ABC/000102 ABC/000103 ABC/000104 ABC/999997 طيب لنفترض انه تم حذف سجلات أخرى والتى تبدأ من الرقم ABC/000105 الى الى الرقم ABC/999997 سوف يكمل الكود ABC/999998 ABC/999999 والى هنا تكون نهاية الترقيم طبقا لاختيار عدد 6 منازل للترقيم فى المحاولة التاليه فورا سوف يتوقف الترقيم عن العمل لذلك لا أنصح بالوقوع فى هه المعضله التى لابد وحتما سوف تحدث فى وقت ما ومشكلة أخرى يمكن أن تحدث مع المعالجة الخاطئة عند الوصول الى القيمة القصوى سوف يتم تكرار هذه القيم دائما يعنى لو افترضنا انه كان عدد المنازل 2 ABC/01 ABC/02 ABC/03 ABC/04 ABC/05 ABC/06 ABC/07 ABC/08 ABC/09 ABC/10 سوف تتم تكرار القيمة القصوى ABC/10 ABC/10 ABC/10 ABC/10 لذلك وجب التنويه الى الانتباه عند تعامل المبرمج مع هذه الجزئيــة وفى المشاركة القادمة ان شاء الله تعالى سوف اضع بين آياديكم تحديث لداله كنت كتبتها قبل ذلك هى داله بشكل عام شامله ووافيه يمكن أن تحقق هذه الجزئية وأكثر من ذلك بكثير حسب رغبة المستخدم أو بالاخص حسب رغبة المصمم ومطور النظم وكنبذه عن الموضوع والفكرة القادمه ان شاء الله تعالى الدالة التى أنوه عنها كانت فى هذه المشاركة ولكن سوف يتم تلافى بعض الأخطاء فى التحديث الجديد لها مع اضافات بسيطه تضفى القوة والمرونة والشموليه بشكل أكثر احترافيه من الاصدار السابق يتبع ......

هههههه طيب مبدئيا وتعالى نقول ليه كودك افضل من الكود الاول والمستخدم فى المرفق : الفرق بينهما المعيار الكود الأول الكود الثاني طريقة الاستعلام يستخدم Recordset مع SELECT TOP 1 ... ORDER BY لجلب أعلى قيمة. يستخدم DMax للحصول على أعلى قيمة مباشرة. الأداء أبطأ نسبيًا لأنه يفتح Recordset ويتعامل مع البيانات يدويًا. أسرع لأن DMax يعمل على مستوى المحرك دون الحاجة إلى فتح Recordset. الدقة دقيق إذا كان النمط ثابتًا (XX/CCCC)، لكنه قد يفشل إذا كان هناك بيانات غير متوقعة. دقيق بنفس القدر، مع تحكم أفضل في شرط البحث باستخدام Right. المرونة أقل مرونة لأنه يعتمد على LIKE وتحليل النص يدويًا. أكثر مرونة لأن DMax يسمح بتخصيص الشرط بسهولة. معالجة الأخطاء جيدة، لكن يمكن تحسينها بإضافة تفاصيل الخطأ. جيدة، لكن قد تفشل إذا كان تعبير DMax معقدًا جدًا. الكفاءة في الذاكرة يستهلك ذاكرة أكثر بسبب Recordset. أقل استهلاكًا لأنه لا يفتح كائنات إضافية. طيب ولأن وقت الجواب كنت صايم وكان وقت الفطار خلاص وكنت مستعجل وبعد قراءة كودك الجميل كودك افضل ولكن ايه رايك فى كتابة الكود بهذه الطريقة Public Function FlexiBranchSerial(tableName As String, serialField As String, branchCode As String, Optional minDigits As Integer = 2) As String On Error GoTo ErrorHandler ' التحقق من المدخلات If Len(Trim(tableName)) = 0 Or Len(Trim(serialField)) = 0 Or Len(Trim(branchCode)) = 0 Then FlexiBranchSerial = "خطأ: مدخلات غير صالحة" Exit Function End If If minDigits < 1 Then minDigits = 2 ' ضمان حد أدنى معقول Dim db As DAO.Database Dim maxSerial As Variant Dim formatPattern As String ' إعداد نمط التنسيق بناءً على minDigits formatPattern = String(minDigits, "0") Set db = CurrentDb ' استخدام DMax للحصول على أعلى قيمة تسلسلية مع شرط دقيق maxSerial = DMax("Val(Left([" & serialField & "], InStr([" & serialField & "], '/') - 1))", tableName, _ "[" & serialField & "] LIKE '*/" & branchCode & "'") ' إذا لم يكن هناك قيمة، ابدأ من 0 If IsNull(maxSerial) Then maxSerial = 0 ' زيادة الرقم التسلسلي بـ 1 maxSerial = maxSerial + 1 ' توليد الرقم التسلسلي النهائي FlexiBranchSerial = Format(maxSerial, formatPattern) & "/" & branchCode Set db = Nothing Exit Function ErrorHandler: Debug.Print "خطأ في FlexiBranchSerial: " & Err.Number & " - " & Err.Description & " | جدول: " & tableName & ", حقل: " & serialField & ", رمز الفرع: " & branchCode FlexiBranchSerial = "خطأ: فشل في توليد الرقم - " & Err.Description End Function وبعد مشاركتى للكود الاخير دعنا نضع مقارنه بين الكود الاول لحضرتك يا استاذ @Foksh والكود الثانى المعيار الكود الأول الكود الثاني طريقة الاستعلام يستخدم QueryDef مع استعلام SQL يدوي لجلب أعلى قيمة باستخدام Max. يستخدم DMax للحصول على أعلى قيمة مباشرة. الأداء أبطأ نسبيًا بسبب إنشاء QueryDef وفتح Recordset في كل استدعاء. أسرع لأن DMax يعمل مباشرة على مستوى محرك قاعدة البيانات دون كائنات إضافية. الدقة دقيق، لكن شرط LIKE '*branchCode' قد يتطابق مع قيم غير مرغوبة (مثل "X/1000Y"). أكثر دقة بسبب شرط LIKE '*/branchCode' الذي يضمن النمط الصحيح. المرونة أقل مرونة (تنسيق ثابت "00"). أكثر مرونة بفضل minDigits لتخصيص عدد الأرقام (مثل "001" أو "0001"). معالجة الأخطاء أساسية، تفتقر إلى تفاصيل الخطأ. أفضل، تتضمن رقم الخطأ والوصف والمدخلات لتسهيل التصحيح. الكفاءة في الذاكرة يستهلك ذاكرة أكثر بسبب QueryDef وRecordset. أقل استهلاكًا لأنه يعتمد على DMax فقط. التحقق من المدخلات أقل دقة (Trim(tableName & serialField & branchCode) قد يفشل إذا كان أحد الحقول فارغًا ولكن الباقي ليس كذلك). أكثر دقة (يتحقق من كل حقل على حدة). تحياتى لكل اساتذتى العظماء

العفو منكم استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل اولا: رمضان كريم و كل عام وانتم بخير و كل عام و انتم الى الله أقرب ثانيا : انتم لا تشاركون مع طلاب العلم بل أنتم تتقدمون كل طلاب العلم و انا قبلهم و أولهم فإذا حضر الماء بطل التيمم بخصوص الثغرة اللى حضرتك قلت عليها عند حذف السجلات فلقد كتبت الكود بهذه الطريقة مستخدما : SELECT TOP لاسد أمامها كل الثغرات تماما طبعا وقطعا هى الافضل على الاطلاق مع الترقيم و يا والدى الحبيب دعنى اعيد صياغة الاجابة على هذه النقطه خصيصا بشرح واف اكثر من ذلك وخاصة مع دوال المجال الثلاث والتى تكون مرجع للمطورين عند عمل الترقيم والتى قد تسبب الحيرة للبعض حتى تتضح الرؤية تماما ان شاء الله وتنكشف الغمة الفرق بين DLast , DCount , DMax مع الترقيم التلقائي وخاصة عند حذف السجلات 1. DLast تستخدم DLast لاسترجاع آخر سجل تمت إضافته إلى الجدول بناء على الترتيب الداخلي لقاعدة البيانات لا تضمن إرجاع آخر قيمة بالمعنى الزمني أو الرقمي لأن ترتيب السجلات ليس ثابتا عند الحذف أو إعادة الإدخال غير موثوقة عند التعامل مع الترقيم التلقائى أو عند الحاجة إلى أعلى قيمة بشكل دقيق 2. DCount تستخدم DCount لحساب عدد السجلات التي تستوفي شرط/شروط لا تعطي أي معلومات عن القيم المخزنة نفسها فقط عدد الإدخالات "السجلات" الموجودة مفيدة عندما تحتاج إلى معرفة عدد السجلات المتبقية بعد الحذف أو عدد السجلات الحاليه اما مطلقا أو مع وجود شرط /شروط 3. DMax تستخدم DMax لاسترجاع أكبر قيمة في حقل معين سواء كان رقميا أو نصيا عند التعامل مع حقل نصي يحتوي على ترقيم تلقائى بتنسيق مثل 1/1000 يجب استخدام DMax مع معالجة إضافية لاستخراج الجزء الرقمي

مشاركة مع حبيبنا وأستاذنا ابا جودي قد اعددت الاجابة قبل الافطار ولم اتمكن من الرفع وقتها هذه محاولتي المختصرة وراعيت فيها لو تغير الرقم الذي يشير الى الفرع على اعتباره 1000 او 2000 او 3000 ... الخ شريطة ان يستمر على هذا النسق Dim i, ii As String Dim x As Integer i = Specialty ii = i & "000" x = DCount("*", "tblDoctors", "[Specialty]='" & i & "'") + 1 Me!DoctorID = Format(Str(x), "00000") & "/" & ii طبعا يوجد ثغرة فيما لو تم حذف سجل فعند الترقيم قد يتم تكرار رقم موجود ، وعادة يكون هو آخر رقم تم تسجيله وعلاجه ان يتم ضبط الحقل بحيث لا يقبل التكرار وقد يستمر هذا الخطأ لأن الكود يعد السجلات مارأي اخي محمد @ابو جودي هل نستخدم Dmax بدلا من ذلك ؟ ترقيم تلقائي حسب الفرع2.rar

اتفضل ترقيم تلقائي حسب الفرع.accdb

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة : ( مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ - الإصدار الثانى ) باختصار بعد هذا الموضوع : اداة مطهر النصوص المرنه - FlexiTextSanitizer الوصف: هي أداة تهدف إلى تنظيف النصوص العربية (وغيرها) بكفاءة عالية مع دعم واسع للتخصيص. توفر الدالة الرئيسية خيارات متعددة لمعالجة النصوص بما في ذلك تطبيع الأحرف العربية إزالة الحركات التحكم في الأرقام والأحرف الخاصة إضافة أقواس تلقائية حول الأرقام الاحتفاظ بالرموز الرياضية مثل √ و∑ المميزات الرئيسية: دعم اللغات: عربية لاتينية أو كلاهما التحكم في الأرقام والرموز: الاحتفاظ بها إزالتها أو إضافة أقواس تلقائية معالجة علامات الترقيم: الاحتفاظ بها كلها إزالتها أو الاكتفاء بالفواصل والنقاط دعم الرموز الرياضية: الاحتفاظ برموز مثل ∞ و≠ في الحالات المحددة التطبيع: توحيد الأحرف العربية (مثل تحويل إِ إلى ا). كيف تعمل؟ المدخلات: نص خام مع خيارات اختيارية (تطبيع - لغة - معالجة - ترقيم) المعالجة: تطبيع الأحرف (اختياري) إزالة الحركات إضافة أقواس حول الأرقام (إذا طُلب) تنظيف النص بناءً على نمط محدد تقليص المسافات المخرجات: نص نظيف و منسق حسب الخيارات المحددة الكود داخل الوحدة النمطية العامة ' تعداد لتحديد وضع اللغة Public Enum LanguageMode ArabicOnly = 0 ' اللغة العربية فقط ArabicAndLatin = 1 ' اللغة العربية واللاتينية LatinOnly = 2 ' اللغة اللاتينية فقط End Enum ' تعداد لتحديد وضع المعالجة Public Enum ProcessingMode KeepAll = 0 ' الاحتفاظ بالأرقام والأحرف الخاصة removeNumbers = 1 ' إزالة الأرقام فقط KeepNumbersOnly = 2 ' الاحتفاظ بالأرقام وإزالة الأحرف الخاصة CleanAll = 3 ' تنظيف كامل (إزالة الأرقام والأحرف الخاصة) KeepBrackets = 4 ' الاحتفاظ بالأرقام والأقواس (مع إضافتها تلقائيًا) KeepSpecialSymbols = 5 ' الاحتفاظ بالرموز الرياضية والخاصة End Enum ' تعداد لتحديد معالجة علامات الترقيم Public Enum punctuationMode KeepAllPunctuation = 0 ' الاحتفاظ بجميع علامات الترقيم RemoveAllPunctuation = 1 ' إزالة جميع علامات الترقيم KeepBasicPunctuation = 2 ' الاحتفاظ فقط بالفواصل والنقاط (, .) End Enum ' الدالة الرئيسية: FlexiTextSanitizer Public Function FlexiTextSanitizer(inputText As String, Optional normalize As Boolean = False, _ Optional langMode As LanguageMode = ArabicOnly, _ Optional processMode As ProcessingMode = KeepAll, _ Optional punctuationMode As punctuationMode = KeepAllPunctuation, _ Optional customSpecialChars As String = "()،؛") As String On Error GoTo ErrorHandler If Nz(inputText, "") = "" Then FlexiTextSanitizer = "" Exit Function End If Dim sanitizedText As String sanitizedText = Trim(inputText) ' الخطوة 1: التطبيع إذا طُلب If normalize Then Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next End If ' الخطوة 2: إزالة الحركات باستخدام RegExp Dim regEx As Object Set regEx = CreateObject("VBScript.RegExp") regEx.Global = True regEx.Pattern = "[\u064B-\u0652\u0670]" ' نطاق الحركات العربية sanitizedText = regEx.Replace(sanitizedText, "") ' إزالة علامة السؤال بشكل افتراضي sanitizedText = Replace(sanitizedText, "?", "") ' الخطوة 3: إضافة أقواس تلقائية حول الأرقام إذا طُلب (KeepBrackets) If processMode = KeepBrackets Then regEx.Pattern = "(\b[\u0660-\u0669\u0030-\u0039]+\b)" ' الأرقام العربية واللاتينية sanitizedText = regEx.Replace(sanitizedText, "($1)") End If ' الخطوة 4: بناء نمط الأحرف المسموح بها Dim allowedPattern As String Select Case langMode Case ArabicOnly allowedPattern = "\u0621-\u064A" ' الأحرف العربية Case ArabicAndLatin allowedPattern = "\u0621-\u064A\u0041-\u007A" ' العربية واللاتينية (A-Z, a-z) Case LatinOnly allowedPattern = "\u0041-\u007A" ' اللاتينية فقط End Select ' إضافة الأرقام والأحرف الخاصة بناءً على وضع المعالجة Select Case processMode Case KeepAll allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039" & EscapeRegExChars(customSpecialChars) Case removeNumbers allowedPattern = allowedPattern & EscapeRegExChars(customSpecialChars) Case KeepNumbersOnly allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039" Case CleanAll ' لا شيء يُضاف (تنظيف كامل) Case KeepBrackets allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\(\)" ' الاحتفاظ بالأرقام والأقواس Case KeepSpecialSymbols allowedPattern = allowedPattern & "\u0660-\u0669\u0030-\u0039\u2200-\u22FF" ' الأرقام والرموز الرياضية End Select ' إضافة علامات الترقيم بناءً على وضع المعالجة Select Case punctuationMode Case KeepAllPunctuation allowedPattern = allowedPattern & "!""#$%&'()*+,-./:;<=>?@[\\]^_`{|}~،؛" Case RemoveAllPunctuation ' لا شيء يُضاف (إزالة كل علامات الترقيم) Case KeepBasicPunctuation allowedPattern = allowedPattern & ",." End Select ' إضافة المسافة دائمًا وتطبيق النمط regEx.Pattern = "[^" & allowedPattern & "\s]" ' إزالة كل ما هو خارج النطاق sanitizedText = regEx.Replace(sanitizedText, "") ' الخطوة 5: تقليص المسافات المتعددة إلى واحدة regEx.Pattern = "\s+" sanitizedText = regEx.Replace(sanitizedText, " ") sanitizedText = Trim(sanitizedText) ' الخطوة 6: إرجاع النتيجة If Len(Trim(Nz(sanitizedText, ""))) = 0 Then FlexiTextSanitizer = vbNullString Else FlexiTextSanitizer = sanitizedText End If Exit Function ErrorHandler: Debug.Print "خطأ في FlexiTextSanitizer: " & Err.Description FlexiTextSanitizer = "" End Function ' دالة مساعدة: EscapeRegExChars Private Function EscapeRegExChars(chars As String) As String Dim specialChars As Variant Dim i As Integer specialChars = Array("^", "$", ".", "*", "+", "?", "(", ")", "[", "]", "{", "}", "|", "\\", "`", "~", "&", "%", "#", "@", "<", ">") For i = LBound(specialChars) To UBound(specialChars) chars = Replace(chars, specialChars(i), "\" & specialChars(i)) Next i EscapeRegExChars = chars End Function اضافة توثيق وشرح للكود فى رأس الموديول ليكون مفهوما ولايضاح الية الاستدعاء بالسيناريوهات المختلفة والممكنة وهذا اختياريا يمكن وضعه قبل الكود السابق ' توثيق الموديول: ' الغرض: هذا الموديول يحتوي على دالة FlexiTextSanitizer لتنظيف النصوص بدقة وسرعة مع دعم مرن للغات (العربية واللاتينية)، الأحرف الخاصة، علامات الترقيم، والرموز الرياضية. ' يستخدم تعدادات (Enums) لتسهيل الاستدعاء وتقليل الأخطاء، ويتيح التحكم الكامل في معالجة النصوص. ' ' سيناريوهات الاستدعاء: ' 1. تنظيف النص مع الاحتفاظ بالأرقام والأحرف الخاصة وعلامات الترقيم بدون تطبيع: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5)" ' 2. تنظيف النص مع إزالة الأرقام بدون تطبيع: ' FlexiTextSanitizer(inputText, False, ArabicOnly, RemoveNumbers, KeepAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم" ' 3. تنظيف النص مع الاحتفاظ بالأرقام فقط مع تطبيع: ' FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation) ' - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم 5 - 5" ' 4. تنظيف كامل مع تطبيع وإزالة علامات الترقيم: ' FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation) ' - مثال الناتج: "اشراف علي بعض الاماكن او المكان رقم" ' 5. تنظيف النص مع الاحتفاظ بالأرقام والأقواس (تلقائية) والفواصل والنقاط مع تطبيع: ' FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation) ' - مثال الناتج: "اشراف علي, بعض الاماكن او المكان رقم (5).(5)" ' 6. تنظيف النص مع دعم العربية واللاتينية والأحرف الخاصة وعلامات الترقيم: ' FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,") ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم (5 - 5) Supervision" ' 7. تنظيف النص مع إزالة جميع علامات الترقيم: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation) ' - مثال الناتج: "إشراف على بعض الأماكن أو المكان رقم 5 5" ' 8. تنظيف النص مع الاحتفاظ بالفواصل والنقاط فقط: ' FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation) ' - مثال الناتج: "إشراف على, بعض الأماكن أو المكان رقم 5.5" ' 9. تنظيف نص يحتوي على علامات ترقيم كثيرة: ' FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "!!!...،،،:::;;;---___***(())" ' 10. تنظيف نص يحتوي على رموز رياضية مع الاحتفاظ بها: ' FlexiTextSanitizer("√∑∫∏∂∆∞ ≠ ± × ÷", False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation) ' - مثال الناتج: "√∑∫∏∂∆∞ ≠ ± × ÷" ' 11. تطبيع جميع الأشكال الممكنة: ' FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation) ' - مثال الناتج: "ا، ا، ا، و، ي، ي، ه، ك، ج" ولكن ملحوطة صغيرة طبعا وللاسف محرر الاكواد هنا مع الاكسس فقيير جدا بعكس لغات البرمجة الاخرى لا يقبل الرموز لذلك الرموز الرياضية مثل : √∑∫∏∂∆∞ سوف تتغير داخل المحرر الى علامات استفهام والان داله يمكن اضافتها فى نهاية الكود وهى مجرد للتجربة طباعه نتائج التجربه فى النافذة الفوريه ليكون المبرمج مطلعا وملما بالنتائج ' اختبار الدالة مع السيناريوهات المطلوبة Sub TestFlexiTextSanitizer() Dim inputText As String inputText = "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ Supervision of some places or place number 5 - 5" Debug.Print "النص الأصلي: " & inputText Debug.Print "------------------------------------" Debug.Print "السيناريو 1 (تنظيف، الاحتفاظ بالأرقام والأحرف الخاصة، بدون تطبيع):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 2 (تنظيف، إزالة الأرقام، بدون تطبيع):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, removeNumbers, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 3 (تنظيف، الاحتفاظ بالأرقام، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepNumbersOnly, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 4 (تنظيف كامل، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, CleanAll, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 5 (تنظيف، الاحتفاظ بالأرقام والأقواس، مع تطبيع):" Debug.Print FlexiTextSanitizer(inputText, True, ArabicOnly, KeepBrackets, KeepBasicPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 6 (العربية واللاتينية مع أحرف خاصة مخصصة والاحتفاظ بجميع علامات الترقيم):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicAndLatin, KeepAll, KeepAllPunctuation, "().,") Debug.Print "------------------------------------" Debug.Print "السيناريو 7 (العربية فقط، إزالة جميع علامات الترقيم):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 8 (العربية فقط، الاحتفاظ بالفواصل والنقاط فقط):" Debug.Print FlexiTextSanitizer(inputText, False, ArabicOnly, KeepAll, KeepBasicPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 9 (نص يحتوي على علامات ترقيم كثيرة جدًا):" Debug.Print FlexiTextSanitizer("!!!؟؟؟...،،،:::;;;---___***((()))", False, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 10 (نص يحتوي على رموز رياضية ورموز خاصة):" Debug.Print FlexiTextSanitizer(ChrW(8730) & ChrW(8721) & ChrW(8747) & ChrW(8719) & ChrW(8706) & ChrW(8710) & ChrW(8734) & ChrW(32) & ChrW(8800) & ChrW(32) & ChrW(177) & ChrW(32) & ChrW(215) & ChrW(32) & ChrW(247), False, ArabicAndLatin, KeepSpecialSymbols, RemoveAllPunctuation) Debug.Print "------------------------------------" Debug.Print "السيناريو 11 (تطبيع جميع الأشكال الممكنة):" Debug.Print FlexiTextSanitizer("إِ، أ، إ، ؤ، ئ، ى، ة، ك، چ", True, ArabicOnly, KeepAll, KeepAllPunctuation) Debug.Print "------------------------------------" End Sub

السلام عليكم... عجبني هذا اليوم الدخول لموقع اكسل رغم اني مش فاهم منه حاجة الا القليل القليل .. جربت الكودين للاساتذة ..واثنينهم شغالات تمام

وعليكم السلام ورحمة الله تعالى وبركاته Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "كلية.xlsb" wsName = "قسم" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.Items Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then ky = "=*" & Me.ComboBox1.Value & "*" lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True ' اختار ما يناسبك UserForm_Initialize 'OR ' Unload Me End If End If End Sub TEST.zip

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub SaveAsPDF() Dim CrWS As Worksheet: Set CrWS = Sheets("بيانات") Dim lastRow As Long: lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row Dim xPath As String: xPath = ThisWorkbook.Path & "\كشف_التلاميذ.pdf" CrWS.Range("A2:J" & lastRow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع") Dim RowDest As Long: RowDest = 1 Dim Irow As Long, tmp As Long, ky As String Application.ScreenUpdating = False ws.Range("L1:L" & ws.Rows.Count).ClearContents For Irow = 7 To ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ky = ws.Cells(Irow, "G").Value If ky <> "" Then tmp = IIf(ky = "آداب و فلسفة", 7, _ IIf(ky = "لغات أجنبية - إسبانية" Or ky = "لغات أجنبية - ألمانية", 8, 9)) For tmp = 1 To tmp ws.Cells(RowDest, 12).Value = ky & tmp RowDest = RowDest + 1 Next tmp End If Next Irow Application.ScreenUpdating = True End Sub Classeur2 v2.xlsm

جرب هدا =IFERROR(INDEX($G$7:$G$19;MATCH(TRUE;MMULT(--(ROW($G$7:$G$19)>=TRANSPOSE(ROW($G$7:$G$19)));$H$7:$H$19)>=ROWS($6:6);0));"")

يمكنك استعمال هذا الكود activesheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\mas.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True بالتوفيق

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

ولك بالمثل اخي لقد لاحظت ان الاعمدة الاخيرة تتضمن روابط المقاطع على اليوتيوب والفايس اليك تحديث الكود لتتمكن من نسخ Hyperlinks المواقع والانتقال اليها عبر الوورد Public Property Get n() As Worksheet: Set n = Worksheets("WordCopy") End Property Sub Copy_Transfer_WORD1() Dim arr() As String: Dim cnt() As String Dim lastRow As Long: Dim rngA As Variant: Dim rngB As Variant Dim OneRng As Range: Dim tmp As Range: Dim Ary As Variant Dim i As Long: Dim r As Integer: Dim x As Long: Dim j As Range Application.DisplayAlerts = False Application.ScreenUpdating = False Set WS = Worksheets("Sheet1") n.Visible = xlSheetVisible: n.Cells.UnMerge n.Range("A1:J" & n.Rows.Count).Clear lige = 7 lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row cnt() = Split("I-H,J-I", ",") rngA = Array(1, 3, 4, 5, 6, 7, 8) rngB = Array(1, 2, 3, 4, 5, 6, 7) For i = 0 To UBound(rngA) With WS Set OneRng = .Range(.Cells(lige, _ rngA(i)), .Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy n.Cells(1, _ rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats End With Next i For r = 0 To UBound(cnt): arr = Split(cnt(r), "-") WS.Range(arr(0) & "8:" & arr(0) & lastRow).Copy Destination:=n.Cells(2, arr(1)) Next r lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set tmp = n.Range("A1:J" & n.Rows.Count) Set a = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) a.RowHeight = 75: a.Font.Bold = True: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14: d.Font.Size = 24 d.Merge: d.Interior.Color = RGB(192, 192, 192): n.[A2:I2].Interior.Color = RGB(215, 238, 247) With E .Font.Name = "AdvertisingBold": .Font.Size = 13 .WrapText = True: .MergeCells = False End With F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 35: Else j.EntireRow.AutoFit Next With tmp .EntireColumn.HorizontalAlignment = xlCenter .EntireColumn.VerticalAlignment = xlCenter End With With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 2024 final V3.xlsm

السلام عليكم إخواني الأعزاء ... لدي قاعدة بيانات وظيفتها صناعة وطباعة شهادات المشاركة للمتدربين وإرسالها لهم بالبريد اللأكتروني .. أو حفظها كملفات PDF أو طباعتها مباشرة ... وهذا شكلها (نموذج) : بعد تعبئة البيانات وإضافة أسماء المتدربين وبياناتهم ثم الضغط على زر [ عرض الشهادات] يتم فتح التقرير الذي يحوي تصميم الشهادات مع البيانات هكذا : المطلوب وكما هو موضح لديكم : 1- طريقة لإرسال جميع الشهادات لجميع المتدربين كل في بريده الإلكتروني ومرفق معه شهادته فقط بصيغة PDF... 2- إمكانية جعل نص الرسالة وعنوانها تقرأ من مربعي النص اللذان بالأسفل كما هو واضح لديكم في الصورة الأولى .. 3- طريقة لحفظ الشهادات بشكل متفرق .. كل شهادة في ملف PDF باسم المتدرب ورقمه الوظيفي . أنتم لها وهي لكم 😄💪🏼 ولكم مني أجمل تحية ،، (مرفق لكم قاعدة البيانات ) إرسال شهادات المتدربين بالإيميل.accdb

اخي اين الملف حتى نعرف المدى والورقة التي ستطبق عليها عالعموم هذا ملف به كود برمجي بمجرد الضغط عليه يتم نسخ المدى بنفس عرض العمود في نفس ورقة العمل Sub width_col() Sheets("sheet1").Range("A1:e50000").Copy With Sheets("sheet1").Range("G1") .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteValues, , False, False .PasteSpecial xlPasteFormats, , False, False End With Application.CutCopyMode = False End Sub FORMAT WIDTH‬.xls

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