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

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

وعليكم السلام ورحمة الله تعالى وبركاته في Module Option Explicit Sub Filtre() Dim tbl() As Variant, rng As Variant Dim desWS As Worksheet, WS As Worksheet Dim i As Long, j As Long, tmp As Long Set WS = Sheets("ورقة2") Set desWS = Sheets("ورقة1") Application.ScreenUpdating = False desWS.Range("A2:D" & desWS.Rows.Count).ClearContents rng = WS.Range("A2:D" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim tbl(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 1) <> "" And rng(i, 4) > 0 Then tmp = tmp + 1 For j = 1 To UBound(rng, 2) tbl(tmp, j) = rng(i, j) Next j End If Next i If tmp > 0 Then desWS.Range("A2").Resize(tmp, UBound(tbl, 2)).Value = tbl Application.ScreenUpdating = True End Sub وفي حدث ورقة1 Private Sub Worksheet_Activate() Call Filtre End Sub مثال.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Dim tmps As Object, cell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary") If Target.Cells.Count > 1 Then Exit Sub For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value Next cell ExitHandler: Exit Sub ClearApp: Set tmps = Nothing Resume ExitHandler End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Or tmps Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then If IsNumeric(cell.Value) Then cell.Value = tmps(cell.Address) + cell.Value Else MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation End If End If Next cell ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub جمع الخلية v3.xlsb

المفروض أن الكود التالي يشتغل معك Sub SortStudents() Dim WS As Worksheet Dim lastRow As Long Dim OnRng As Range Set WS = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Application.ScreenUpdating = True Exit Sub End If Set OnRng = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear .SortFields.Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .SortFields.Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending .SetRange OnRng .Header = xlYes .Apply End With Application.ScreenUpdating = True End Sub ترتيب الاوائل v3.xlsb

Sub StringSort() Dim WS As Worksheet Dim lastRow As Long Dim sortRange As Range ' اسم ورقة العمل (يمكن تغييره) Const SHEET_NAME As String = "Sheet1" Application.ScreenUpdating = False ' التحقق من وجود ورقة العمل On Error Resume Next Set WS = ThisWorkbook.Sheets(SHEET_NAME) On Error GoTo 0 If WS Is Nothing Then MsgBox "ورقة العمل '" & SHEET_NAME & "' غير موجودة.", vbExclamation GoTo Cleanup End If ' العثور على الصف الأخير في العمود A lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row ' التحقق من وجود بيانات If lastRow < 2 Then MsgBox "لا توجد بيانات للفرز.", vbExclamation GoTo Cleanup End If ' تحديد نطاق الفرز Set sortRange = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear With .SortFields .Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending .Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending End With .SetRange sortRange .Header = xlYes .Apply End With Cleanup: Application.ScreenUpdating = True End Sub

غريب الكود يشتغل معي بشكل جيد اليك حل اخر لاختيار ما يناسبك Option Explicit Sub SortArray() Dim a() As Variant, i As Long, j As Long, col As Long Dim temp As Variant, lastRow As Long, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row Set OnRng = WS.Range("A1:E" & lastRow) a = OnRng.Value For i = 2 To UBound(a, 1) - 1 For j = i + 1 To UBound(a, 1) If a(i, 3) < a(j, 3) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 3) = a(j, 3) Then If a(i, 4) > a(j, 4) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col ElseIf a(i, 4) = a(j, 4) Then If a(i, 5) > a(j, 5) Then For col = 1 To UBound(a, 2) temp = a(i, col) a(i, col) = a(j, col) a(j, col) = temp Next col End If End If End If Next j Next i OnRng.Value = a End Sub ترتيب الاوائل v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته =IFERROR(VLOOKUP(E13, $Q$12:$U$14, MATCH(D13, $Q$11:$U$11, 0), FALSE), "") New Microsoft Excel Worksheet.xlsx

ضبط التلاعب بتاريخ الكمبيوتر الشرح بالفيديو التالي . Manipulating computer Date settings.rar

السلام عليكم ورحمة الله وبركاته تفضل ربما يفيدك هذا تم وضع معادلة في H5 واستعمال التنسيق الشرطي للخلايا من A5:H14 ويمكن زيادة هذا النطاق إلى أي نهاية دعواتكم لي بسعة الرزق في هذه الايام المباركة مطلوب من أوفيسنا الكرام.xlsx

جرب هذه المعادلة شرح المعادلة ROUND(L4/280*100,1): تقوم هذه الدالة بحساب النسبة المئوية وتقريبها إلى خانة عشرية واحدة. INT(ROUND(L4/280*100,1)): تقوم هذه الدالة بإرجاع الجزء الصحيح من الرقم المقرب. IF(ROUND(L4/280*100,1)=INT(ROUND(L4/280*100,1)),...,...): تقوم هذه الدالة بالتحقق مما إذا كان الرقم المقرب مساويًا للجزء الصحيح منه. إذا كان مساويًا، فهذا يعني أن الرقم صحيح، وإلا فهو عشري. TEXT(ROUND(L4/280*100,1),"0"): إذا كان الرقم صحيحًا، تقوم هذه الدالة بتحويله إلى نص بدون أصفار عشرية. TEXT(ROUND(L4/280*100,1),"0.0"): إذا كان الرقم عشريًا، تقوم هذه الدالة بتحويله إلى نص بخانة عشرية واحدة. مثال إذا كانت L4 تحتوي على 140، فإن الناتج سيكون 50. إذا كانت L4 تحتوي على 141، فإن الناتج سيكون 50.4. آمل أن تكون هذه المعادلة المعدلة تحقق المطلوب. =IF(ROUND(L3/280*100;1)=INT(ROUND(L3/280*100;1));TEXT(ROUND(L3/280*100;1);"0");TEXT(ROUND(L3/280*100;1);"0.0"))

وعليكم السلام ورحمة الله تعالى وبركاته في الجزء الأخير من الكود قم بإظافة هدا With crWS.PageSetup xlSheet.PageSetup.PaperSize = .PaperSize xlSheet.PageSetup.Orientation = .Orientation xlSheet.PageSetup.LeftMargin = .LeftMargin xlSheet.PageSetup.RightMargin = .RightMargin xlSheet.PageSetup.TopMargin = .TopMargin xlSheet.PageSetup.BottomMargin = .BottomMargin xlSheet.PageSetup.HeaderMargin = .HeaderMargin xlSheet.PageSetup.FooterMargin = .FooterMargin xlSheet.PageSetup.PrintArea = .PrintArea xlSheet.PageSetup.PrintTitleRows = .PrintTitleRows xlSheet.PageSetup.PrintTitleColumns = .PrintTitleColumns xlSheet.PageSetup.Zoom = .Zoom End With ActiveWindow.View = xlPageBreakPreview ActiveWindow.Zoom = 100 حدود طباعة ثابتة v2.xlsm

عذرا اخي الكريم لم أنتبه لأنك تستعمل نسخة أوفيس 2007 وبالفعل هذه الميزة غير موجودة فيه يمكنك استعمال كود الطباعة العادي في حالة وجود طابعة pdf في ويندوز يمكنك تجربة هذا الكود Sub ExportWorksheetToPDF_2007() Dim ws As Worksheet Dim pdfFilePath As String Dim wbPath As String Dim objPrinter As Object ' تحديد ورقة العمل الحالية Set ws = ActiveSheet ' الحصول على مسار المصنف الحالي wbPath = ThisWorkbook.Path ' التحقق مما إذا كان المصنف قد تم حفظه If wbPath = "" Then MsgBox "يرجى حفظ المصنف أولاً لتحديد المسار.", vbExclamation Exit Sub End If ' تحديد مسار واسم ملف PDF pdfFilePath = wbPath & "\" & ws.Name & ".pdf" On Error Resume Next ' تحديد طابعة الـ PDF الافتراضية Set objPrinter = CreateObject("Scripting.FileSystemObject") If objPrinter Is Nothing Then MsgBox "لا يمكن تصدير PDF. يرجى التأكد من تثبيت إضافة التصدير.", vbCritical Exit Sub End If ' تصدير الورقة باستخدام طابعة PDF خارجية ws.PrintOut Copies:=1, ActivePrinter:="Microsoft Print to PDF", _ PrintToFile:=True, PrToFileName:=pdfFilePath MsgBox "تم تصدير ورقة العمل إلى ملف PDF بنجاح: " & pdfFilePath, vbInformation End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته 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

للأسف لا يوجد معادلة للقيام بهذا الأمر إلا في الإصدارات الحديثة وربما تكون طويلة ومعقدة ولكن يمكنك استعمال هذا الاجراء Sub RepeatValuesInColumn() Dim ws As Worksheet Dim sourceRow As Long Dim targetRow As Long Dim repeatCount As Long Dim lastRow As Long ' تحديد ورقة العمل Set ws = ActiveSheet ' الحصول على آخر صف يحتوي على بيانات في العمود G lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ' تحديد صف البدء للعمود J targetRow = 7 ' ابدأ من الصف J7 ' التكرار لكل صف في العمود G وH For sourceRow = 7 To lastRow If ws.Cells(sourceRow, "G").Value <> "" And IsNumeric(ws.Cells(sourceRow, "H").Value) Then repeatCount = ws.Cells(sourceRow, "H").Value If repeatCount > 0 Then Dim i As Long For i = 1 To repeatCount ws.Cells(targetRow, "J").Value = ws.Cells(sourceRow, "G").Value targetRow = targetRow + 1 Next i End If End If Next sourceRow MsgBox "تم التكرار بنجاح!", vbInformation End Sub بالتوفيق

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

ما اقصده اخي انك اخترت إجابتك كأفضل إجابة ، وليس إجابة الأستاذ @ابو عارف التي وجدت بها الحل . كل الشكر والتقدير لشخصك الكريم 🤗 وتقبل الله منكم الصيام 🤲🏻

تفضل حبيبي Full Control Of Print Report.mdb

طيب ممكن مشاركة اثراء للموضوع يا استاذ @Foksh ايه رايك طالما كده كده هنعمل اكواد داخل موديول نتوسع فى الافكار ونشطح بخيالنا حبتين علشان يكون قفلنا كل المشاكل الممكن حدوثها شوف يا سيدى انا اقصد بالمشاكل مثلا عندك شهر ابريل ممكن يكون أبريل وشهر يونيه ممكن يكون يونيو ده على سبيل المثال وليس الحصر خلينا بقه نستخدم القواميس الممتعه فى شغلها ونكتب الداله من خلالها بالشكل ده Option Compare Database Option Explicit ' تهيئة القواميس مرة واحدة فقط لتوفير الأداء Dim monthsDict As Object Dim daysDict As Object ' دالة لإنشاء قاموس ديناميكيًا Public Function CreateDictionary() As Object Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' تهيئة القواميس عند بدء التشغيل Sub InitializeDictionaries() If monthsDict Is Nothing Then Set monthsDict = InitializeMonthsDictionary() If daysDict Is Nothing Then Set daysDict = InitializeDaysDictionary() End Sub Function GetDaysInfo(monthInput As Variant, Optional yearValue As Variant = -1, Optional targetDay As Variant = "MonthDays") As Variant Dim MonthNumber As Long Dim firstDay As Date Dim totalDays As Long Dim daysArray(1 To 7) As Long Dim currentDate As Date Dim result As Variant Dim i As Long ' تهيئة القواميس مرة واحدة InitializeDictionaries '--- تعديل رئيسي: التحقق من السنة --- If IsMissing(yearValue) Or yearValue = -1 Then yearValue = Year(Date) ' استخدام السنة الحالية إذا لم تُحدد Else ' التأكد من أن yearValue هو رقم صحيح If Not IsNumeric(yearValue) Then GetDaysInfo = "خطأ: السنة يجب أن تكون رقمًا" Exit Function End If yearValue = CLng(yearValue) End If ' تعيين السنة الحالية إذا لم تُمرر If yearValue = 0 Then yearValue = Year(Date) ' معالجة إدخال الشهر If IsNumeric(monthInput) Then MonthNumber = CLng(monthInput) Else MonthNumber = GetNumberFromDict(monthsDict, monthInput) End If If MonthNumber < 1 Or MonthNumber > 12 Then GetDaysInfo = "خطأ في الشهر: " & monthInput & vbCrLf & "الأشهر المتاحة: " & Join(monthsDict.Keys, ", ") Exit Function End If ' حساب أيام الشهر totalDays = Day(DateSerial(yearValue, MonthNumber + 1, 0)) firstDay = DateSerial(yearValue, MonthNumber, 1) ' تهيئة المصفوفة For i = 1 To 7 daysArray(i) = 0 Next i ' حساب أيام الأسبوع (الأحد = 1) For i = 0 To totalDays - 1 currentDate = firstDay + i daysArray(Weekday(currentDate, vbSunday)) = daysArray(Weekday(currentDate, vbSunday)) + 1 Next i ' معالجة طلب اليوم المستهدف Select Case True Case targetDay = "MonthDays" Or targetDay = "أيام_الشهر" result = totalDays Case targetDay = "ALL" Or targetDay = "الكل" result = daysArray Case Else Dim dayCode As Long dayCode = GetNumberFromDict(daysDict, targetDay) If dayCode = 0 Then GetDaysInfo = "خطأ في اليوم: " & targetDay & vbCrLf & "الأيام المتاحة: " & Join(daysDict.Keys, ", ") Exit Function End If result = daysArray(dayCode) End Select GetDaysInfo = result End Function Function InitializeMonthsDictionary() As Object Dim dict As Object Set dict = CreateDictionary() With dict ' شهر 1 .Add "1", 1 .Add "jan", 1 .Add "january", 1 .Add "يناير", 1 .Add "ينا", 1 .Add "ين", 1 ' شهر 2 .Add "2", 2 .Add "feb", 2 .Add "february", 2 .Add "فبراير", 2 .Add "فبر", 2 .Add "فب", 2 ' شهر 3 .Add "3", 3 .Add "mar", 3 .Add "march", 3 .Add "مارس", 3 .Add "ماس", 3 .Add "ما", 3 ' شهر 4 .Add "4", 4 .Add "apr", 4 .Add "april", 4 .Add "أبريل", 4 .Add "إبريل", 4 .Add "ابريل", 4 .Add "ابر", 4 ' شهر 5 .Add "5", 5 .Add "may", 5 .Add "مايو", 5 .Add "ماي", 5 ' شهر 6 .Add "6", 6 .Add "jun", 6 .Add "june", 6 .Add "يونية", 6 .Add "يونيه", 6 .Add "يونيو", 6 .Add "يون", 6 ' شهر 7 .Add "7", 7 .Add "jul", 7 .Add "july", 7 .Add "يوليو", 7 .Add "يوليه", 7 .Add "يولية", 7 .Add "يول", 7 ' شهر 8 .Add "8", 8 .Add "aug", 8 .Add "august", 8 .Add "أغسطس", 8 .Add "اغسطس", 8 .Add "أغس", 8 ' شهر 9 .Add "9", 9 .Add "sep", 9 .Add "september", 9 .Add "سبتمبر", 9 .Add "سبت", 9 ' شهر 10 .Add "10", 10 .Add "oct", 10 .Add "october", 10 .Add "أكتوبر", 10 .Add "اكتوبر", 10 .Add "أكت", 10 ' شهر 11 .Add "11", 11 .Add "nov", 11 .Add "november", 11 .Add "نوفمبر", 11 .Add "نوف", 11 ' شهر 12 .Add "12", 12 .Add "dec", 12 .Add "december", 12 .Add "ديسمبر", 12 .Add "ديس", 12 End With Set InitializeMonthsDictionary = dict End Function Function InitializeDaysDictionary() As Object Dim dict As Object Set dict = CreateDictionary() With dict ' الأحد .Add "1", 1 .Add "sun", 1 .Add "sunday", 1 .Add "الأحد", 1 .Add "الاحد", 1 .Add "أحد", 1 .Add "احد", 1 .Add "ح", 1 ' الإثنين .Add "2", 2 .Add "mon", 2 .Add "monday", 2 .Add "الإثنين", 2 .Add "الاثنين", 2 .Add "إثنين", 2 .Add "اثنين", 2 .Add "ن", 2 ' الثلاثاء .Add "3", 3 .Add "tue", 3 .Add "tuesday", 3 .Add "الثلاثاء", 3 .Add "ثلاثاء", 3 .Add "ث", 3 ' الأربعاء .Add "4", 4 .Add "wed", 4 .Add "wednesday", 4 .Add "الأربعاء", 4 .Add "الاربعاء", 4 .Add "أربعاء", 4 .Add "ر", 4 ' الخميس .Add "5", 5 .Add "thu", 5 .Add "thursday", 5 .Add "الخميس", 5 .Add "خميس", 5 .Add "خ", 5 ' الجمعة .Add "6", 6 .Add "fri", 6 .Add "friday", 6 .Add "الجمعة", 6 .Add "الجمعه", 6 .Add "جمعة", 6 .Add "جم", 6 .Add "ج", 6 ' السبت .Add "7", 7 .Add "sat", 7 .Add "saturday", 7 .Add "السبت", 7 .Add "سبت", 7 .Add "س", 7 End With Set InitializeDaysDictionary = dict End Function Function GetNumberFromDict(dict As Object, key As Variant) As Long key = LCase(Trim(CStr(key))) If dict.Exists(key) Then GetNumberFromDict = dict(key) Else GetNumberFromDict = 0 End If End Function ودى كل نتائج الكود من خلال استعلام SELECT shr, GetDaysInfo([shr], 0, "MonthDays") AS عدد_أيام_الشهر, GetDaysInfo([shr], 0, "Sunday") AS عدد_أيام_الأحد, GetDaysInfo([shr], 0, "Monday") AS عدد_أيام_الاثنين, GetDaysInfo([shr], 0, "Tuesday") AS عدد_أيام_الثلاثاء, GetDaysInfo([shr], 0, "Wednesday") AS عدد_أيام_الأربعاء, GetDaysInfo([shr], 0, "Thursday") AS عدد_أيام_الخميس, GetDaysInfo([shr], 0, "ج") AS عدد_أيام_الجمعة, GetDaysInfo([shr], 0, "السبت") AS عدد_أيام_السبت FROM data_shr; المميزات فى الكود دعم كامل للغات: يقبل المدخلات بالعربية والإنجليزية (كاملة ومختصرة) كفاءة عالية: تهيئة القواميس مرة واحدة فقط مرونة استثنائية: يقبل حتى الاختصارات غير التقليدية واقصد بذلك الأشهر: إضافة اختصارات مثل "ينا" (يناير), "فبر" (فبراير), "ابر" (أبريل), "ديس" (ديسمبر) الأيام: إضافة اختصارات مثل "ح" (الأحد), "ن" (الإثنين), "جم" (الجمعة) توثيق ذاتي: يعرض جميع الخيارات المتاحة عند حدوث خطأ شئ مهم كمان: ثبات النتائج: تم تثبيت بداية الأسبوع على يوم الأحد باستخدام Weekday(currentDate, vbSunday) لتجنب تأثير إعدادات النظام و لحساب الأيام بشكل دقيق تقدر تجرب من خلال الاستعلام ده شوف فى الاستدعاء الطرق المختلفة لشهر اكتوبر وليوم الاحد والتى تظهر المرونة المطلقة فى الاستدعاء SELECT shr, GetDaysInfo(10,0,"MonthDays") AS عدد_أيام_الشهر, GetDaysInfo("اكتوبر", 0, "ح") AS 2عدد_أيام_الأحد, GetDaysInfo("اكتوبر", 0, "أحد") AS 3عدد_أيام_الأحد, GetDaysInfo("اكتوبر", 0, "sun") AS 4عدد_أيام_الأحد, GetDaysInfo(10, 0, 1) AS 5عدد_أيام_الأحد FROM data_shr;

وعليكم السلام ورحمة الله تعالى وبركاته بالنسبة للكود المقدم لك مسبقا يمكنك تعديله على الشكل التالي Private Sub CommandButton16_Click() Dim Tmam_Wbk As Workbook, TPath As String If ComboBox28.Value = "" Then MsgBox "من فضلك أختار التجهيزة": Exit Sub If OptionButton1.Value Then TPath = ThisWorkbook.Path & "\تمام\مدينة\" & ComboBox28.Value ElseIf OptionButton2.Value Then TPath = ThisWorkbook.Path & "\تمام\محافظات\" & ComboBox28.Value End If If Len(Dir(TPath & ".xlsx")) > 0 Then TPath = TPath & ".xlsx" ElseIf Len(Dir(TPath & ".xls")) > 0 Then TPath = TPath & ".xls" Else MsgBox "الملف غير موجود": Exit Sub End If On Error GoTo ErrorHandler Set Tmam_Wbk = Workbooks.Open(TPath) Unload Me Exit Sub ErrorHandler: Unload Me End Sub هنا قمت بتعديل الامتدادات على عدة أكواد للتجربة Run V3.xls

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

وعليكم السلام تفضل Full Control Of Print Report.mdb

السلام عليكم ورحمة الله تعالى وبركاته كل عام وانتم بخيــر يأتى شهر الخير ومعه البركات أقدم اليكم هدية قيمة بكل ما تحمل الكلمة من معنى فى هذا الموضوع من أفكار وأكواد وفوائد هامة لا غنى عنها مطلقا ذات مرة شاركت بكتابة موضوع بخصوص انشاء الجداول واضافة الحقول وخصائصها برمجيا وهذا هو الموضوع واستكمالا لما تم طرحه فى هذا الموضوع السابق الاشارة اليه تعديل وتطوير بعض الاكواد والافكار لاضفاء مرونة واحترافيه وكفائه اكبر الفائده : امكانية عمل الجداول الاساسية بشكل ديناميكى من خلال الكود دون أدنى تدخل من المستخدم الغرض : سهول ومرونة وحفاظا على البيانات والاعدادت الاساسية للتطبيق طيب علشان سامع واحد هناك بيقول ايه يعم ده دا عمل الجدول اسهل واسرع من وجع الدماغ ده هو كلامه صح ... عارف ولكــــن لتوضيح المميزات والآفكار دعونا نمضى فى هذا الموضوع وهذه احد الفوائد العظيمة و الهامة على سبيل المثال فقط وليس الحصر الفكرة كالاتى عمل دالة مركزية للاخطاء داخل الأكواد الفوائد العظيمه من ورائها مرونة فائقة : ✔ إنشاء جداول بشكل ديناميكى لحفظ وتتبع ارقام و وصف و أماكن الأخطاء داخل الإجراءات و زوايا التطبيق المختلفة ..... ✔ إنشاء جداول بشكل ديناميكى للتحكم فى إعدادت التعامل مع الدالة المركزية ✔ إعادة البيانات الاعدادت داخل الجدول اذا تم العبث بها " قسراً " ✔ إعدة الحقول والبيانات اذا تم حذفها" قسراً " ✔ إعادة إنشاء الجداول بشكل ديناميكى مرة أخرى أخرى أذا تم حذفها " قسراً " لنمضى قدما بع هذه المقدمة - وحدة نمطية عامة رئيسية باسم : basTablesCreator الأكواد بداخل الوحدة النمطية Option Compare Database Option Explicit ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' تعريف تعداد لأنواع الحقول المتاحة في قاعدة البيانات Public Enum FieldTypes dbBoolean = 1 ' نوع الحقل: Yes/No (قيمة منطقية) dbByte = 2 ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255) dbInteger = 3 ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767) dbLong = 4 ' نوع الحقل: Long Integer (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647) dbCurrency = 5 ' نوع الحقل: Currency (عدد عشري بدقة عالية للحسابات المالية) dbSingle = 6 ' نوع الحقل: Single (عدد عشري بدقة بسيطة) dbDouble = 7 ' نوع الحقل: Double (عدد عشري بدقة مزدوجة) dbDate = 8 ' نوع الحقل: Date/Time (تاريخ ووقت) dbText = 10 ' نوع الحقل: Text (نص عادي يصل إلى 255 حرفًا) dbMemo = 12 ' نوع الحقل: Memo (نص طويل جدًا) dbAutoNumber = 15 ' نوع الحقل: AutoNumber (ترقيم تلقائي) dbBinary = 128 ' نوع الحقل: Binary (بيانات ثنائية صغيرة) dbVarBinary = 205 ' نوع الحقل: OLE Object (بيانات ثنائية كبيرة مثل ملفات OLE) dbAttachment = 101 ' نوع الحقل: Attachment (ملفات مرفقة) dbBigInt = 16 ' نوع الحقل: BigInt (عدد صحيح كبير جدًا، 64 بت) dbMultipleChoice = 109 ' نوع الحقل: Multiple Choice (حقل متعدد الخيارات) End Enum ' دالة لإنشاء قاموس جديد عند الحاجة إليه Public Function CreateDictionary() As Object Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' إجراء لإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldTypes, _ Optional fieldSize As Long = 0, _ Optional fieldFormat As String = "", _ Optional defaultValue As Variant = Null, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "") Dim fieldDict As Object Set fieldDict = CreateDictionary() With fieldDict .Add "Name", fieldName .Add "Type", fieldType .Add "Size", fieldSize .Add "Caption", fieldCaption .Add "Description", fieldDescription .Add "DefaultValue", defaultValue .Add "Format", fieldFormat End With If Fields Is Nothing Then Set Fields = CreateDictionary() Set Fields(fieldName) = fieldDict End Sub ' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات Public Function IsTableExist(TableName As String) As Boolean Dim tdf As DAO.TableDef For Each tdf In CurrentDb.TableDefs If tdf.Name = TableName Then IsTableExist = True Exit Function End If Next tdf IsTableExist = False End Function ' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا Public Sub CreateNewTable(TableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' التحقق مما إذا كان الجدول موجودًا بالفعل If IsTableExist(TableName) Then db.TableDefs.Delete TableName db.TableDefs.Refresh End If ' إنشاء كائن TableDef جديد Set tdf = db.CreateTableDef(TableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' إضافة الحقول إلى الجدول For Each key In Fields.Keys ' الحصول على القاموس الخاص بكل حقل Set fieldDict = Fields(key) ' التحقق من صحة البيانات If fieldDict.Exists("Name") And fieldDict.Exists("Type") Then ' إنشاء الحقل If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) ' تعيين الحجم إذا كان الحقل نصيًا If fieldDict("Type") = dbText Then If fieldDict.Exists("Size") And fieldDict("Size") > 0 Then fld.Size = fieldDict("Size") Else MsgBox "حجم الحقل النصي غير صالح!", vbCritical Exit Sub End If End If Else ' إنشاء حقل AutoNumber Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If ' تعيين القيمة الافتراضية إذا كانت مدعومة If fieldDict.Exists("DefaultValue") Then On Error Resume Next fld.defaultValue = fieldDict("DefaultValue") On Error GoTo 0 End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld Else MsgBox "خطأ: بيانات الحقل غير مكتملة!", vbCritical Exit Sub End If Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf db.TableDefs.Refresh End Sub ' دالة لفحص ما إذا كان الجدول مفتوحًا وإغلاقه إذا لزم الأمر Public Function CloseTableIfNecessary(TableName As String) As Boolean On Error Resume Next DoCmd.Close acTable, TableName CloseTableIfNecessary = (Err.Number = 0) On Error GoTo 0 End Function ' هذا الإجراء يقوم بإضافة أو تحديث خصائص الحقول في الجدول Public Sub SetFieldProperties(TableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim fieldDict As Object Dim key As Variant Dim prop As DAO.Property ' الحصول على قاعدة البيانات الحالية Set db = CurrentDb() ' الحصول على الكائن TableDef للجدول الذي سيتم التحديث فيه Set tdf = db.TableDefs(TableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه If IsFieldExist(tdf, fieldDict("Name")) Then Set fld = tdf.Fields(fieldDict("Name")) ' إضافة أو تحديث التسمية (Caption) إذا كانت موجودة If fieldDict.Exists("Caption") And fieldDict("Caption") <> "" Then On Error Resume Next fld.Properties.Delete "Caption" ' حذف التسمية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة التسمية الجديدة fld.Properties.Append fld.CreateProperty("Caption", dbText, fieldDict("Caption")) End If ' إضافة أو تحديث الوصف (Description) إذا كان موجودًا If fieldDict.Exists("Description") And fieldDict("Description") <> "" Then On Error Resume Next fld.Properties.Delete "Description" ' حذف الوصف الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة الوصف الجديد fld.Properties.Append fld.CreateProperty("Description", dbText, fieldDict("Description")) End If ' إضافة أو تحديث التنسيق (Format) إذا كان موجودًا If fieldDict.Exists("Format") And fieldDict("Format") <> "" Then On Error Resume Next fld.Properties.Delete "Format" ' حذف التنسيق الحالي إذا كان موجودًا On Error GoTo 0 ' إضافة التنسيق الجديد fld.Properties.Append fld.CreateProperty("Format", dbText, fieldDict("Format")) End If ' تحديث القيمة الافتراضية (DefaultValue) بشكل صارم If fieldDict.Exists("DefaultValue") Then On Error Resume Next fld.defaultValue = Null ' حذف القيمة الافتراضية الحالية إذا كانت موجودة On Error GoTo 0 ' إضافة القيمة الافتراضية بناءً على نوع الحقل If Not IsNull(fieldDict("DefaultValue")) And Trim(Nz(fieldDict("DefaultValue"), "")) <> "" Then ' التحقق من أن الحقل ليس من النوع AutoNumber If fieldDict("Type") <> dbAutoNumber Then Select Case fieldDict("Type") Case dbText, dbMemo, dbAttachment ' للحقول النصية، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) Case dbInteger, dbLong, dbBigInt, dbByte ' للحقول العددية، نقوم بتحويل القيمة إلى رقم fld.defaultValue = CStr(Nz(fieldDict("DefaultValue"), 0)) Case dbDate ' للحقول التاريخية، نقوم بتحويل القيمة إلى تنسيق تاريخ fld.defaultValue = Format(Nz(fieldDict("DefaultValue"), Now()), "yyyy-mm-dd hh:mm:ss") Case Else ' لأي نوع آخر، نقوم بتحويل القيمة إلى سلسلة fld.defaultValue = CStr(fieldDict("DefaultValue")) End Select Else ' إذا كان الحقل من النوع AutoNumber، لا نقوم بتعيين قيمة افتراضية ' Debug.Print "Skipping defaultValue for AutoNumber field: " & fieldDict("Name") End If Else ' إذا كانت القيمة الافتراضية فارغة أو Null، نقوم بإزالة القيمة الحالية If fieldDict("Type") <> dbAutoNumber Then fld.defaultValue = "" End If End If End If End If Next key End Sub ' دالة لبناء شرط البحث Private Function BuildCriteria(record As Object, uniqueFields As Variant, TableName As String) As String Dim criteria As String Dim fieldName As String Dim fieldValue As Variant Dim fieldType As DAO.DataTypeEnum Dim fieldIndex As Variant ' التحقق من أن record هو قاموس If Not TypeOf record Is Object Or TypeName(record) <> "Dictionary" Then BuildCriteria = "" Exit Function End If ' بناء شرط البحث باستخدام الحقول الفريدة criteria = "" For Each fieldIndex In uniqueFields fieldName = Trim(fieldIndex) If record.Exists(fieldName) Then fieldValue = record(fieldName) ' التحقق من أن القيمة ليست Null أو فارغة If Not IsNull(fieldValue) And Trim(CStr(fieldValue)) <> "" Then If criteria <> "" Then criteria = criteria & " AND " ' الحصول على نوع الحقل من الجدول fieldType = GetFieldType(TableName, fieldName) ' التعامل مع القيم بناءً على نوع الحقل ' التعامل مع القيم بناءً على نوع الحقل Select Case fieldType Case dbText, dbMemo criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'" Case dbInteger, dbLong, dbByte, dbSingle, dbDouble, dbCurrency, dbBigInt criteria = criteria & "[" & fieldName & "] = " & fieldValue Case dbBoolean criteria = criteria & "[" & fieldName & "] = " & IIf(fieldValue, -1, 0) Case dbDate criteria = criteria & "[" & fieldName & "] = #" & Format(fieldValue, "yyyy-mm-dd hh:mm:ss") & "#" Case Else criteria = criteria & "[" & fieldName & "] = '" & Replace(CStr(fieldValue), "'", "''") & "'" End Select End If End If Next fieldIndex ' إذا لم يتم بناء شرط البحث، يعني أن القاموس فارغ If criteria = "" Then BuildCriteria = "" Else BuildCriteria = criteria End If End Function ' للحصول على نوع الحقل Private Function GetFieldType(TableName As String, fieldName As String) As DAO.DataTypeEnum Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Set db = CurrentDb() Set tdf = db.TableDefs(TableName) On Error Resume Next Set fld = tdf.Fields(fieldName) If Err.Number <> 0 Then GetFieldType = dbText ' نوع افتراضي إذا لم يتم العثور على الحقل Exit Function End If On Error GoTo 0 GetFieldType = fld.Type End Function ' دالة مساعدة لتنسيق القيمة حسب النوع Private Function FormatFieldValue(value As Variant) As String If IsDate(value) Then FormatFieldValue = "#" & Format(value, "mm/dd/yyyy hh:nn:ss AM/PM") & "#" ElseIf IsNumeric(value) Then FormatFieldValue = CStr(value) Else FormatFieldValue = "'" & Replace(CStr(value), "'", "''") & "'" End If End Function ' دالة لتحديد ما إذا كان الحقل من نوع AutoNumber Function IsAutoNumberField(fld As DAO.Field) As Boolean IsAutoNumberField = (fld.Type = dbAutoNumber) End Function ' الإجراء الرئيسي لإنشاء أو تحديث الجدول وإدخال البيانات Public Sub CreateOrModifyTableAndInsertData(TableName As String, Fields As Object, _ Optional records As Collection = Nothing, _ Optional uniqueFieldNames As String = "", _ Optional bAddData As Boolean = False) Dim db As DAO.Database Dim rs As DAO.Recordset Dim record As Object Dim uniqueFields() As String Dim criteria As String Set db = CurrentDb() '--- 1. إغلاق الجدول إذا كان مفتوحًا --- If Not CloseTableIfNecessary(TableName) Then MsgBox "لا يمكن تعديل الجدول لأنه مفتوح.", vbExclamation Exit Sub End If '--- 2. إنشاء الجدول إذا لم يوجد --- If Not IsTableExist(TableName) Then CreateNewTable TableName, Fields Else '--- 3. تحديث الهيكل فقط إذا كان bAddData = True --- If bAddData Then Dim tdf As DAO.TableDef Set tdf = db.TableDefs(TableName) EnsureFieldsExist tdf, Fields End If End If '--- 4. تطبيق خصائص الحقول --- SetFieldProperties TableName, Fields '--- 5. معالجة البيانات --- If bAddData And Not records Is Nothing And uniqueFieldNames <> "" Then uniqueFields = Split(uniqueFieldNames, ", ") Set rs = db.OpenRecordset(TableName, dbOpenDynaset) For Each record In records ' التحقق من أن record هو قاموس If TypeOf record Is Object And TypeName(record) = "Dictionary" Then ' بناء شرط البحث مع تمرير اسم الجدول criteria = BuildCriteria(record, uniqueFields, TableName) ' Debug.Print criteria ' التحقق من صحة الشرط If criteria <> "" Then rs.FindFirst criteria If rs.NoMatch Then rs.AddNew Else rs.Edit End If ' تحديث القيم Dim key As Variant For Each key In record.Keys If Not IsAutoNumberField(rs.Fields(key)) Then rs(key) = record(key) End If Next key rs.Update Else ' Debug.Print "Invalid criteria for record. Skipping..." End If Else ' Debug.Print "Element in records is not a valid Dictionary. Skipping..." End If Next record rs.Close End If Application.RefreshDatabaseWindow End Sub ' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول Public Function IsFieldExist(tdf As DAO.TableDef, fieldName As String) As Boolean Dim fld As DAO.Field For Each fld In tdf.Fields If fld.Name = fieldName Then IsFieldExist = True Exit Function End If Next fld IsFieldExist = False End Function ' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة Public Sub EnsureFieldsExist(tdf As DAO.TableDef, Fields As Object) Dim fieldDict As Object Dim fld As DAO.Field Dim key As Variant ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not IsFieldExist(tdf, fieldDict("Name")) Then ' إنشاء الحقل بناءً على النوع If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type"), fieldDict("Size")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField ' تعيين الحقل كـ AutoNumber End If ' تعيين القيمة الافتراضية إذا كانت محددة If Not IsNull(fieldDict("DefaultValue")) And fieldDict("DefaultValue") <> "" Then fld.defaultValue = fieldDict("DefaultValue") End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld End If Next key End Sub ' دالة مساعدة للتحقق من القيم الفارغة أو Null Private Function IsEmptyOrNull(value As Variant) As Boolean IsEmptyOrNull = IsNull(value) Or Trim(CStr(value)) = "" End Function الغرض منها : ✔ هى التى تحتوى على الجراءات والوظائف الاساسية لعملية إنشاء الجداول والحقول وخصائص الحقول - وحدة نمطية عامة ثانوية باسم : basTablesInitialization الاكواد بداخلها Option Compare Database Option Explicit ' متغير لكتابة اسم الحقل/الحقول الفريدة لضمان عدم تكرار السجلات Dim uniqueFields As String ' هذا الإجراء يقوم بتهيئة الجدول الخاص بتسجيل الأخطاء Public Sub InitializeTableErrorLog() Dim tblName As String ' اسم جدول تسجيل الأخطاء tblName = "tblErrorLog" ' إنشاء القاموس لاحتواء الحقول Set Fields = CreateDictionary() ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي" AddFieldToDictionary "ErrorDate", dbDate, , "dddd, mmmm dd, yyyy hh:nn:ss AM/PM", "Now()", "وقت حدوث الخطأ", "الغرض :تسجيل وقت و تاريخ حدوث الخطأ" AddFieldToDictionary "Source", dbText, 255, "@[red]", , "الإجراء/الوظيفة", "الغرض :اسم الإجراء/الوظيفة/النموذج/الوحده النمطية/التقرير الذي حدث فيه الخطأ" AddFieldToDictionary "ErrorNumber", dbLong, , , , "رقم الخطأ", "الغرض :تسجيل رقم الخطأ المرتبط بـ الإجراء/الوظيفة Err.Number" AddFieldToDictionary "ErrorDescription", dbText, 255, "@[Blue]", , "وصف الخطأ", "الغرض :تسجيل الوصف التفصيلي للخطأ كما يظهر في: Err.Description" AddFieldToDictionary "UserName", dbText, 100, "", , "حدث الخطأ مع المستخدم", "حقل : يحتوى على سجل من: Environ USERNAME" AddFieldToDictionary "CallExecutionTrace", dbMemo, , , , "تسلسل تنفيذ الأكواد", "الغرض :تسجيل جميع الإجراءات التي تم تنفيذها قبل حدوث الخطأ، مما يسهل تتبع مصدر المشكلة" AddFieldToDictionary "AdditionalInfo", dbText, 255, , , "معلومات إضافيه", "الغرض :تسجيل معلومات إضافية مخصصة يضيفها المطور عند استدعاء قيم متغيرات مهمة عند حدوث الخطأ" CreateOrModifyTableAndInsertData tblName, Fields, , , False End Sub Public Sub InitializeErrorSettingsTable() Dim tblName As String ' اسم جدول أعدادت الوظيفة المركزية للتعامل مع الأخطاء tblName = "tblErrorSettings" ' إنشاء القاموس لاحتواء الحقول Set Fields = CreateDictionary() ' إضافة الحقول ومعلومات كل حقل: ' (اسم الحقل - نوع الحقل - حجم الحقل - التنسيق - القيمة الافتراضية - التسمية - الوصف) AddFieldToDictionary "ID", dbAutoNumber, , , , "المعرف", "الغرض :الترقيم التلقائي" AddFieldToDictionary "ConfigKey", dbInteger, , , , "رقم فريد للإعداد", "الغرض :تسجيل رقم فريد لكل الإعدادات في النظام للقيم المعرفة" AddFieldToDictionary "ConfigValue", dbBoolean, , , False, "قيمة الإعداد", "الغرض :تسجيل القيمة المرتبطة بمفتاح الإعدادات: (تفعيل / تعطيل الإعداد)" AddFieldToDictionary "ConfigDescription", dbText, 100, "@[red]", , "وصف الإعداد", "الغرض :تسجيل الوصف والغرض من الإعدادات" ' إنشاء مجموعة السجلات الافتراضية Dim records As New Collection ' إضافة السجلات ' السجل الأول Dim record1 As Object, record2 As Object, record3 As Object Set record1 = CreateDictionary() record1("ConfigKey") = 1 record1("ConfigValue") = True record1("ConfigDescription") = "ErrorLoggingEnabled :التحكم في تفعيل/تعطيل تسجيل الأخطاء في التطبيق في جدول الأخطاء" records.Add record1 ' السجل الثانى Set record2 = CreateDictionary() record2("ConfigKey") = 2 record2("ConfigValue") = True record2("ConfigDescription") = "ShowErrorMessages : التحكم في تفعيل/تعطيل عرض رسائل الخطأ للمستخدم" records.Add record2 ' السجل الثالث Set record3 = CreateDictionary() record3("ConfigKey") = 3 record3("ConfigValue") = True record3("ConfigDescription") = "DebugMode : التحكم في تفعيل/تعطيل وضع التصحيح لتتبع الأخطاء بشكل مفصل في النافذة الفورية" records.Add record3 ' تحديد الحقل/الحقول - الفريد/الفريدة والتى تمنع عملية تكرار البيانات بإضافة سجلات uniqueFields = "ConfigKey" ' إنشاء أو تعديل الجدول وإدخال البيانات CreateOrModifyTableAndInsertData tblName, Fields, records, uniqueFields, True End Sub الغرض منها : ✔ انشاء الجداول الاجبارية والحقول اللازمة وملئ البيانات ------------------------------------------------------------- - وحدة نمطية عامة رئيسية باسم basErrorHandler الاكواد بداخلها Option Compare Database Option Explicit Public ProcedureName As String '### إعدادات التكوين (يمكن إدارتها عبر جدول tblErrorSettings) ### Private Enum ConfigKey ErrorLoggingEnabled = 1 ShowErrorMessages = 2 DebugMode = 3 ErrorLogTable = 4 End Enum '### الهيكل الأساسي لتسجيل الأخطاء ### Private Type ErrorInfo Source As String Number As Long Description As String User As String CallExecutionTrace As String recordData As String End Type ' متغير عام لتخزين سلسلة الاستدعاءات Public gCallExecutionTrace As Collection ' ثابت خاص لتخزين اسم جدول تسجيل الأخطاء Private Const TableNameErrorLog As String = "tblErrorLog" ' ثابت خاص لتخزين اسم جدول إعدادات الأخطاء Private Const TableNameErrorSettings As String = "tblErrorSettings" '============================================================================== ' الدوال الرئيسية للاستخدام الخارجي '============================================================================== ' معالجة الخطأ الرئيسية (يمكن استدعاؤها من أي مكان) Public Sub HandleError(SourceProc As String, Optional ShowMessage As Boolean = True, Optional AdditionalInfo As String = "") Dim errInfo As ErrorInfo Dim errNum As Long, errDesc As String ' حفظ تفاصيل الخطأ قبل أي عمليات أخرى errNum = Err.Number errDesc = Err.Description On Error GoTo ErrorHandlerFailure With errInfo .Source = SourceProc .Number = errNum .Description = errDesc .User = Environ("USERNAME") .CallExecutionTrace = GetCallExecutionTrace() .recordData = AdditionalInfo End With InitializeErrorSettingsTable InitializeTableErrorLog ' تسجيل الخطأ إذا كان التسجيل مفعلاً If GetConfig(ErrorLoggingEnabled, True) Then LogError errInfo End If ' عرض رسالة الخطأ إذا كان مسموحاً If ShowMessage And GetConfig(ShowErrorMessages, True) Then ShowErrorMessage errInfo End If ' تصحيح الأخطاء إذا كان وضع التصحيح مفعلاً If GetConfig(DebugMode, False) Then DebugPrintError errInfo End If Exit Sub ErrorHandlerFailure: ' Fallback إذا فشل معالج الخطأ نفسه MsgBox "Critical failure in error handler: " & Err.Description, vbCritical End Sub '============================================================================== ' الدوال الداخلية '============================================================================== ' تسجيل الخطأ في قاعدة البيانات Private Sub LogError(errInfo As ErrorInfo) Dim db As DAO.Database Dim rs As DAO.Recordset On Error GoTo LogErrorFailed Set db = CurrentDb() Set rs = db.OpenRecordset(GetConfig(ErrorLogTable, TableNameErrorLog), dbOpenTable, dbAppendOnly) With rs .AddNew !ErrorDate = Now() !Source = Left$(errInfo.Source, 255) !ErrorNumber = errInfo.Number !ErrorDescription = Left$(errInfo.Description, 255) !UserName = Left$(errInfo.User, 50) !CallExecutionTrace = Left$(errInfo.CallExecutionTrace, 1000) !AdditionalInfo = Left$(errInfo.recordData, 255) .Update End With Cleanup: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Sub LogErrorFailed: ' Fallback: تسجيل في ملف نصي إذا فشل التسجيل في قاعدة البيانات LogToTextFile "ErrorLog_" & Format(Now(), "yyyymmdd") & ".log", errInfo Resume Cleanup End Sub ' عرض رسالة خطأ مخصصة للمستخدم Private Sub ShowErrorMessage(errInfo As ErrorInfo) Dim msg As String msg = GetErrorMessage(errInfo.Number) & vbCrLf & _ "Details: " & errInfo.Description & vbCrLf & _ "Contact: Technical Support" MsgBox msg, vbExclamation, "Error " & errInfo.Number End Sub ' طباعة تفاصيل الخطأ للنافذة المباشرة (لأغراض التصحيح) Private Sub DebugPrintError(errInfo As ErrorInfo) Debug.Print "=== ERROR DEBUG ===" Debug.Print "Time: " & Now() Debug.Print "Source: " & errInfo.Source Debug.Print "Error " & errInfo.Number & ": " & errInfo.Description Debug.Print "User: " & errInfo.User Debug.Print "Call ExecutionTrace: " & errInfo.CallExecutionTrace Debug.Print "Additional Info: " & errInfo.recordData Debug.Print "===================" End Sub '============================================================================== ' دوال مساعدة '============================================================================== ' الحصول على إعدادات النظام من جدول التكوين Private Function GetConfig(key As ConfigKey, defaultValue As Variant) As Variant Static configCache As Collection Dim rs As DAO.Recordset Dim sql As String If configCache Is Nothing Then Set configCache = New Collection End If On Error Resume Next GetConfig = configCache(CStr(key)) If Err.Number = 0 Then Exit Function sql = "SELECT ConfigValue FROM " & TableNameErrorSettings & " WHERE ConfigKey = " & key Set rs = CurrentDb.OpenRecordset(sql) If Not rs.EOF Then GetConfig = rs!ConfigValue Else GetConfig = defaultValue End If configCache.Add GetConfig, CStr(key) rs.Close Set rs = Nothing End Function ' الحصول على رسالة خطأ مخصصة Private Function GetErrorMessage(ErrorNumber As Long) As String Select Case ErrorNumber Case 3021: GetErrorMessage = "No records found. Please check your data." Case 3061: GetErrorMessage = "Missing parameter in query." Case 7874: GetErrorMessage = "Invalid file format." Case Else: GetErrorMessage = "An unexpected error occurred." End Select End Function '============================================================================== ' دوال إدارة سلسلة الاستدعاءات/الإجراءات التي تم تنفيذها حتى حدوث الخطأ ' ExecutionTrace '============================================================================== Public Sub LogCallExecutionTrace(ProcName As String) If gCallExecutionTrace Is Nothing Then Set gCallExecutionTrace = New Collection gCallExecutionTrace.Add ProcName End Sub Public Sub RemoveFromCallExecutionTrace(ProcName As String) If gCallExecutionTrace Is Nothing Then Exit Sub If gCallExecutionTrace.count = 0 Then Exit Sub ' البحث عن آخر تكرار للاسم وإزالته Dim i As Integer For i = gCallExecutionTrace.count To 1 Step -1 If gCallExecutionTrace(i) = ProcName Then gCallExecutionTrace.Remove i Exit For End If Next i End Sub Private Function GetCallExecutionTrace() As String Dim i As Integer Dim ExecutionTrace As String If gCallExecutionTrace Is Nothing Or gCallExecutionTrace.count = 0 Then GetCallExecutionTrace = "Call ExecutionTrace Empty" Exit Function End If For i = 1 To gCallExecutionTrace.count ExecutionTrace = ExecutionTrace & " > " & gCallExecutionTrace(i) Next i If Len(ExecutionTrace) > 0 Then ExecutionTrace = Mid(ExecutionTrace, 4) End If GetCallExecutionTrace = ExecutionTrace End Function ' تسجيل الخطأ في ملف نصي كحل بديل Private Sub LogToTextFile(FileName As String, errInfo As ErrorInfo) Dim fnum As Integer fnum = FreeFile() Open CurrentProject.Path & "\" & FileName For Append As #fnum Print #fnum, "[" & Now() & "] Error " & errInfo.Number & " in " & errInfo.Source Print #fnum, "User: " & errInfo.User Print #fnum, "Description: " & errInfo.Description Print #fnum, "----------------------------------------" Close #fnum End Sub الغرض والفائدة : ✔ إدارة الأخطاء بطريقة مركزيه منظمة وفعالة إدارة الأخطاء بشكل موحد: يوفر الكود آلية مركزية للتعامل مع الأخطاء في كافة أجزاء التطبيق ✔ إمكانية تتبع الأخطاء وتخزين تفاصيلها في قاعدة البيانات أو في ملف نصي التسجيل التلقائي للأخطاء: يقوم بتخزين الأخطاء مع تفاصيلها في قاعدة البيانات مما يسهل تتبعها وتحليلها لاحقًا ✔ تقديم رسائل مخصصة للمستخدم تخصيص الرسائل: يتيح عرض رسائل خطأ مخصصة للمستخدم مع معلومات إضافية حول الأخطاء التي حدثت ✔ التصحيح والتتبع (Debugging) يسمح بتسجيل معلومات التصحيح مثل سلسلة الاستدعاءات (Call Stack) واستخدام أوضاع تصحيح الأخطاء مما يسهل اكتشاف مصدر المشكلة يساعد المطورين على فهم تفاصيل الخطأ بسرعة بفضل تتبع سلسلة الاستدعاءات بحيث يكون من السهل تحديد أي إجراء أو وظيفة تسببت في الخطأ ✔ المرونة في إدارة التحكم في الإعدادت يمكن تخصيص إعدادات الكود مثل تمكين أو تعطيل التسجيل للأخطأء فى الجدول - تمكين أو تعطيل عرض الرسائل - تمكين أو تعطيل وضع التصحيح عبر جدول الإعدادات مما يجعل الحل مرنًا وقابلًا للتكيف دون الحاجة لتغيير الكود نفسه حسب الرغبة✔ ✔ وظائف مساعدة تتضمن الوظائف المساعدة مثل GetConfig التي تسترجع إعدادات النظام من الجدول: tblErrorSettings و كذلك LogCallExecutionTrace التي تسجل تفاصيل الإجراءات أو الوظائف التي تم استدعاؤها وكذلك LogToTextFile لتسجيل الأخطاء في ملف نصي إذا فشل التسجيل في جدول : tblErrorLog ------------------------------------------------------------- - وحدة نمطية عامة ثانوية باسم basErrorHandlerTest ---- هذه الوحدة النمطية فقط للتجربة ولتوضيح طريقة استخدام الاجراء المركزى الموحد فى تتبع الخطأ يمكن حذفها الاكواد بداخلها والتى يمكن تشغيلها من خلا F5 أو Run للتجربـــة '============================================================================== ' مثال مفرد لتجربة الخطأ '============================================================================== Public Sub TestProcedure() On Error GoTo ErrorHandler ProcedureName = "TestProcedure" LogCallExecutionTrace ProcedureName Dim x As Integer x = 1 / 0 ' خطأ Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable x=" & x Resume Cleanup End Sub Public Sub TestOpenForm() On Error GoTo ErrorHandler ProcedureName = "TestOpenForm" LogCallExecutionTrace ProcedureName Dim strFormName As String strFormName = "Moh3sam" DoCmd.OpenForm strFormName, acNormal ' خطأ لا يوجد نموذج أصلا بهذا الاسم Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable strFormName=" & strFormName Resume Cleanup End Sub '============================================================================== ' مثال لعدة إجراءات مترابطه لتجربة تتبع مكان حدوث الخطأ تحديدا ' ExecutionTrace '============================================================================== Public Sub StartProcess() On Error GoTo ErrorHandler ProcedureName = "StartProcess" LogCallExecutionTrace ProcedureName ProcessNumber01 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber01() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber01" LogCallExecutionTrace ProcedureName ProcessNumber02 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber02() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber02" LogCallExecutionTrace ProcedureName ProcessNumber03 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName Resume Cleanup End Sub Private Sub ProcessNumber03() On Error GoTo ErrorHandler ProcedureName = "ProcessNumber03" LogCallExecutionTrace ProcedureName ' خطأ القسمة على صفر Dim x As Integer x = 1 / 0 Cleanup: RemoveFromCallExecutionTrace ProcedureName Exit Sub ErrorHandler: HandleError ProcedureName, AdditionalInfo:="Variable x=" & x Resume Cleanup End Sub أمثالة تطبيقية : ✔ مثال مفرد : TestProcedure خطأ عند القسمة على 0 ✔ مثال مفرد : TestOpenForm خطأ عند محاولة فتح نموذج غير موجود ✔ مثال معقد يعتمد على عدة وظائف لتجربة التتبع : StartProcess وهنا تكمن الفائدة عند تشغيل أى إجراء أو مثال من أمثلة الخطأ السابقة - إعداد الجداول اللازمة والاعدادت بشكل الى واعادتها - ظهور الرسائل المخصصة لعرض الأخطاء بشكل موحد - تسجيل الأخطاء داخل الجدول ------------------------------- تسهيلا على الجميع - تم اضافة نموج للتجربة ------------------------------- - عند فتح القاعدة للمرة الاولى لن تجدوا بها اى جداول - بمجرد فتح النموذج والضغط على اى من أزرار تجربة الأخطاء سوف يتم إنشاء الجداول والبيانات الخاصة بالاعدادات - يمكنكم تجربة العبث فى جدول الاعدادت " tblErrorSettings " بتفيير البيانات او حذف احد الحقول أو الجدول نفسه وإعادة التجربة فلن يأثر العبث هذا سلبا على الاعدادت وعمل الجراءات وهذه هى الفائدة من الشق الاول فى الموضوع وهو انشاء الجداول والحقول والبيانات الهامة قسرا واخيــــرا المرفق أتمنى أن تكونوا قد إستمتعتم معنا فى منتدانا الرائـــــــع دالة مركزية للتعامل مع الأخطاء.zip

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

وعليكم السلام ورحمة الله تعاى وبركاته اقتراح اخر Option Explicit Sub test() Dim lastRow, i As Long, OnRng, tmp, key As Variant Dim name As String, amount As Double, dict As Object Dim WS As Worksheet: Set WS = Sheets("ورقة1") With WS lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Exit Sub Set dict = CreateObject("Scripting.Dictionary"): OnRng = .Range("B2:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) name = Trim(OnRng(i, 1)): amount = OnRng(i, 2): If name <> "" Then dict(name) = dict(name) + amount Next i Application.ScreenUpdating = False .Range("E2:F" & lastRow).ClearContents If dict.Count = 0 Then: Exit Sub ReDim tmp(1 To dict.Count, 1 To 2) i = 1 For Each key In dict.keys tmp(i, 1) = key: tmp(i, 2) = dict(key): i = i + 1 Next key .Range("E2").Resize(dict.Count, 2).Value = tmp Application.ScreenUpdating = True End With End Sub

جمع اقساط للاسماء المتشابهة.xlsm

اضغط على زر النتيجة الأحمر ولاحظ النتيجة تفضل جمع اقساط.xlsm

النموذج جيد ، ولكنه يشترط تكبير النموذج Maximize بحجم الشاشة لكي يعمل .. وأنا بحثت في مكتبتي فوجدت مثال قديم يقوم بتحجيم جميع العناصر حتى عند تغيير حجم النموذج 🙂 وطبعا للأسف لم أخزن اسم صاحب المثال .. ولكن هاكموه كما وجدته : ملاءمة عناصر النموذج حسب حجم النموذج ☺.mdb

السلام عليكم كل عام وانتم طيبين اولا مشاركه مع اخى محمد البرناوى جزاه الله خيرا وع حسب المرفق الذى ارفقته يوجد لديك سجلات فى الجدول tbl_Loans وفى الحقل Loan_ID فارغ وتخص شهر 3 وهذا الحقل مطلوب فى بعض الدوال لاستخراج القيم قم بحذف هذه السجلات وتقريبا حوالى 163 سجل وستجد بان النتائج قد ظهرت بصوره طبيعيه بالتوفيق

طيب اليكم المرفق الاخيـــــــــــــــــــر المميزات : الاعتماد الكامل على الرقم القومى دوال منفصلة لسهولة استدعائها فى استعلام من خلال الرقم القومى يتم استخراج الجنس/النوع استخراج مكان الميلاد استخراج تاريخ الميلاد حساب العمر بالسنوات حساب العمر بالأشهر حساب العمر بالأيام بناء على حقل تاريخ الميلاد المستخرج من الرقم القومى يتم عمل التالى حساب تاريخ التقاعد حساب سن التقاعد السنوات المتبقيه للتقاعد الاشهر المتبقيه للتقاعد الايام المتبقيه للتقاعد افتح الاستعلام فى القاعده والذى يحمل الاسم : qryAllInfoFromNationalID المرونة المطلقه فقط عند نقل الوحدات النمطية الى اى قاعدة بيانات عمل استعلام وفقط تغير اسم الحقل الخاص بالرقم القومى تبعا للمسمى الموجود فى الجدول الخاص بكم والملون هنا باللون الاحمر BirthDateFromNationalID: GetBirthDateFromNationalID([Emp_NationalID]) وباقى حقول الاستعلام جميعا تعتمد على هذا الحقل لذلك يتم نقلها كما هى ولكن ولكن ولكن لا تغير اسم الحقل : BirthDateFromNationalID لان هذا الاسم تعتمد باقى وكل الحقول الاخرى عليه اعتقد بهذا المرفق يكون الموضوع قتل بحثا وتم عمل كل ما يمكن فيه ويمكن وبكل سهولة ومرونة الان استخدام الحقول المناسبه حسب الحاجه داخل التقارير او النماذج بكل بساطه تم اضافة : نموذج : frmAllInfoFromNationalID تقريــر : rptAllInfoFromNationalID مصدر بيانات كل منهما الاستعلام : qryAllInfoFromNationalID اما النموذج : frmEmployees مصدر بياناته هو الجدول مباشرة الان القاعده كاملة و متكاملة مع تحقيق أقصى درجات المرونه المطلقة والحصول على كل البيانات الممكنه من خلال الرقم القومى مباشره سن التقاعد (8).accdb

الكود يتم تنفيده على الورقة النشطة Dim WS As Worksheet: Set WS = ActiveSheet لتحديد ورقة معينة قم باستبداله على الشكل التالي Dim WS As Worksheet: Set WS = Sheets("Sheet1") 'اسم ورقة العمل

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor تهدف إلى توفير حلول مرنة وفعالة لتنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق بالعمليات تم تصميم هذه الوحدة لتلبية احتياجات المطورين المختلفة والمتنوعة وتعرف او شائعه لدى المطورين باسم : ShellWait ولكن تم اعادة هيكلة وتطوير الوظائف بشكل احترافى لاضفاء أكبر قدر ممكن من الفاعليه والمرونة والكفائه وتعدد الاستخدمات ودعم تنوع الخيارات الممكنه بقدر الإمكان مميزات الكود المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting) التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم وظيفة الكود تتيح وحدة basShellExecutor تشغيل الأوامر والملفات بثلاث طرق مختلفة مع القدرة على التحكم في وقت التنفيذ و معالجة الأحداث والتقاط النتائج الدوال الرئيسية هي: ExecuteAndWait: الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه) ExecuteWithTimeout: الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية) ExecuteWScript: الغرض: تنفيذ أمر بسيط باستخدام " WScript.Shell " مع خيار الانتظار الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD) ExecuteWScriptCapture (اختياري): الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " ) اسم الوحدة النمطية العامة : basShellExecutor الكود : ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function وأخيــــرا الامثلة : '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

تفضل أخي Private Const sFolder As String = "الكشوفات PDF" Private Const NamePDF As String = "كشف مناداة" Private Const CrWS As String = "لجان 4" Private Const Logo As String = "IMG" Sub Copy_SavePDFfinal() Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, img As Shape, r As Shape Dim lastRow As Long, Rng As Range, OnRng As Range Dim f As Worksheet: Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value Set OnRng = f.Range("B2:O45") If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", _ vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set WS = Sheets("PDF") If WS Is Nothing Then Sheets.Add.Name = "PDF" Set WS = Sheets("PDF") WS.DisplayRightToLeft = True End If On Error GoTo 0 tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).row If WS.Cells(2, 3).Value = "" Then Set Rng = WS.Range("B" & lastRow + 1) Else lastRow = WS.Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set Rng = WS.Range("B" & lastRow + 5) End If OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths WS.Cells.NumberFormat = "0;-0;;@" On Error Resume Next Set img = f.Shapes(Logo) If Not img Is Nothing Then img.Copy WS.Paste Destination:=WS.Cells(Rng.row - 1, "F") Set img = WS.Shapes(Logo) img.Top = img.Top If img.Left + img.Width > WS.Range("O1").Left Then img.Left = WS.Range("O1").Left - img.Width End If If img.Top + img.Height > WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top Then img.Top = WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top - img.Height End If End If On Error GoTo 0 For row = 1 To OnRng.Rows.Count WS.Rows(Rng.row + row - 1).RowHeight = OnRng.Rows(row).RowHeight Next row WS.HPageBreaks.Add Before:=WS.Cells(Rng.row + OnRng.Rows.Count, 1) With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .CenterHorizontally = True End With Application.CutCopyMode = False Next i sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 f.[B1].Value = 1 WS.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub المصنف v3.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const sFolder As String = "ملفات PDF" Private Const CrWS As String = "لجان 4" Sub SavePDF() Dim f As Worksheet, début As Integer, fin As Integer, i As Integer Dim sPath As String, sName As String, tempFile As String Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i sName = f.[F7].Value & IIf(f.[M7].Value <> "", " - " & f.[M7].Value, "") sPath = tempFile & "\" & "Page - " & sName & ".pdf" On Error Resume Next f.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub المصنف v2.xlsb

تفضل أخي test (3).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 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

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

أقرت المملكة العربية السعودية منذ أيام قليلة رمزاً جديداً للريال السعودي، في هذا المقطع 3 طرق تشرح كتابة رمز الريال السعودي وإدراجه في برنامج اكسل، سواء إدراجه كصورة أو كحرف (رمز) من لوحة المفاتيح.

هذا ما فعلته أخى لأنه فى بداية المشاركة لم يكن يجيب سوى الأخ العزيز أبو عارف .. والسؤال الآن موجه لك : ماذا تقصد بالضبط !!!!

وعليكم السلام ورحمة الله وبركاته .. من خلال تصميمك للجدول ، نستطيع انشاء دالة عامة في مديول كالتالي - بناءً على أسماء الأشهر لديك :- Function CalculateFridaysSaturdays(monthName As String, year As Integer, Optional dayType As String = "Both") As Variant Dim monthNumber As Integer Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim fridays As Integer Dim saturdays As Integer Select Case monthName Case "يناير" monthNumber = 1 Case "فبراير" monthNumber = 2 Case "مارس" monthNumber = 3 Case "ابريل" monthNumber = 4 Case "مايو" monthNumber = 5 Case "يونيو" monthNumber = 6 Case "يوليو" monthNumber = 7 Case "اغسطس" monthNumber = 8 Case "سبتمبر" monthNumber = 9 Case "اكتوبر" monthNumber = 10 Case "نوفمبر" monthNumber = 11 Case "ديسمبر" monthNumber = 12 Case Else CalculateFridaysSaturdays = "اسم الشهر غير صحيح" Exit Function End Select startDate = DateSerial(year, monthNumber, 1) endDate = DateSerial(year, monthNumber + 1, 0) fridays = 0 saturdays = 0 currentDate = startDate Do While currentDate <= endDate If Weekday(currentDate) = vbFriday Then fridays = fridays + 1 ElseIf Weekday(currentDate) = vbSaturday Then saturdays = saturdays + 1 End If currentDate = currentDate + 1 Loop If dayType = "Friday" Then CalculateFridaysSaturdays = fridays ElseIf dayType = "Saturday" Then CalculateFridaysSaturdays = saturdays Else CalculateFridaysSaturdays = Array(fridays, saturdays) End If End Function ومن خلال استعلام تحديث ، تستطيع استدعاء الدالة لتحديث القيم في الحقلين حسب السنة الحالية كالآتي :- UPDATE data_shr SET gm = CalculateFridaysSaturdays([shr], Year(Date()), "Friday"), sbt = CalculateFridaysSaturdays([shr], Year(Date()), "Saturday"); النتيجة ، افتح استعلام التحديث Query2 وشوف النتيجة في المرفق التالي :- ايام الغياب.accdb

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل بالاستعلام التالي :- SELECT D.Cood, IIf([D].[Percent]*100 <= 60 Or [S].[natio] = 'S', "خارج", [S].[Tans]) AS Expr1 FROM S INNER JOIN D ON S.Cood = D.Cood; جرب الاستعلام وأخبرني بالنتيجة !! 😊

وعليكم السلام ورحمة الله تعاللى وبركاته أخي @Mharee Accounting Albaig يفضل دائما إلغاء باسوورد محرر الأكواد قبل رفع الملف لتفادي إهدار الوقت في كسره جرب هدا Private Sub CommandButton1_Click() On Error GoTo ErrorHandler Dim xlSheet As Worksheet, xlSh As Worksheet, crWS As Worksheet Dim Sht As Worksheet, B As VbMsgBoxResult, T As Long, i As Long, LastCol As Long Set Sht = ThisWorkbook.Sheets("كشف") Set crWS = ThisWorkbook.Sheets("الناسخة ") If Me.BackColor = 192 Or TextBox1.Text = "" Then MsgBox IIf(Me.BackColor = 192, "الاسم مرفوض نصياً", "خلايا فارغة"), vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub End If For Each xlSh In ThisWorkbook.Worksheets If xlSh.Name = Trim(TextBox1.Text) Then MsgBox "اسم مكرر", vbInformation + vbMsgBoxRight, "تنبيه": Exit Sub Next xlSh B = MsgBox("هل تريد اضافة" & vbNewLine & vbNewLine & "الحساب: " & _ TextBox1.Text, vbOKCancel + vbQuestion + vbMsgBoxRight, "تأكيد اضافة حساب") If B = vbCancel Then Exit Sub Application.ScreenUpdating = False Set xlSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) With xlSheet .Name = TextBox1.Text crWS.Range("A1:R74").Copy .Cells.PasteSpecial Paste:=xlPasteAllUsingSourceTheme .Cells.PasteSpecial Paste:=xlPasteColumnWidths ActiveSheet.DisplayRightToLeft = True LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column If LastCol > 18 Then LastCol = 18 .Range(.Cells(1, 1), .Cells(1, LastCol)).AutoFilter .PageSetup.LeftHeader = "كشف حساب " & TextBox1.Text .PageSetup.RightHeader = "اسم الشركة: Bina Puri sdn Bhd" With ActiveWindow .FreezePanes = True .DisplayGridlines = False End With xlSheet.Range("A1").Select End With T = Sht.Range("B" & Sht.Rows.Count).End(xlUp).Row + 1 For i = 1 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(i).Name <> Sht.Name And ThisWorkbook.Sheets(i).Name <> crWS.Name Then Sht.Range("B" & T) = ThisWorkbook.Sheets(i).Name T = T + 1 End If Next i Cleanup: Application.ScreenUpdating = True Set xlSheet = Nothing Set Sht = Nothing Exit Sub ErrorHandler: Resume Cleanup End Sub ورقة بالفلتر.xlsm

وعليكم السلام ورحمة الله وبركاته .. بدايةً لن أنصحك بالإعتماد على كود تخطي الأخطاء هذا بشكل أساسي في مشاريعك ، لأنه قد يترتب عليه تخطي خطأ باكمال معلومة أو معادلة أو إجراء أو نتيجة ستكون قد بنيت عليها إجراءات أخرى ، وعليه تقع في مشاكل .. - على العموم استخدم الكود في حدث عند التحميل للنموذج ، وسيبقى مفعلاً لكل الأكواد الأخرى داخل النموذج طالما لم يتم تغييره في أي إجراء آخر . - أولاً لم أقم بتجربتها ، جرب استعماله في حدث On Error للنموذج كإجراء عام .

مشاركة مع اخي فادي للفائدة العامة مشروع تأجير المركبات : 1- تكون المركبة هي رأس الهرم في المشروع ، اما العميل فهو فرع سبب بسيط بديهي : المركبة يتناوب عليها الكثير من العملاء وقد يستأجرها عميل طارىء مرة واحدة فقط المركبة هي المصدر المالي للمشروع ويجري عليها العمليات المختلفة : تحصيل اجور/ نفقات صيانة / تأمين / مبالغ للوقود / اجرة سائق ان وجد ..... الخ

في حدث Before Update أو After Update الخاص بالحقل ضع هذا السطر Me.FADD = LTrim(Me.FADD)

بدون الحاجة لأي تدخل برمجي أعتقد أنه بإمكانك إعادة تنسيق وتظبيط تنسيق التقرير وتضغير الحقول والخطوط لتلائم حجم ال A4 مباشرة 🙂 وهذه تجربتي : base_A.accdb

جرب هل هدا ما تقصده Option Explicit Sub Split_names() Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s& Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range Dim Arr As Variant, rng As Variant, sp As Variant, Choisir As VbMsgBoxResult Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة") Dim ColNam As String: ColNam = "DM" Choisir = MsgBox("تحديث البيانات ؟", vbYesNo + vbQuestion, "تأكيد") If Choisir <> vbYes Then Exit Sub Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j For s = 9 To 38 dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0) Next s With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub نسب ومؤشر الفائدة v4.xlsb

وعليكم السلام : الطريقة من خطوتين : الخطوة الأولى : أن ترسل نموذج من الملف لأنه لا يمكن التخمين على شيء غير موجود لا بد أن نعرف في أي عمود تتواجد الأسماء وهل تم إدخالها يدويا أم عن طريق قائمة منسدلة أم ... أم , والمبالغ في أي عمود ؟؟؟؟؟؟ كل هذه تساؤلات لا يمكن العمل معها الخطوة الثانية : إذا تم إزالة كل المشاكل سيتم بناء كود يحسب مطلوبك تقبل تحياتي , و مبارك عليك الشهر (رمضان1446هـ)