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

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

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

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

ارفق للمهتمين نموذج للنسخ الاحتياطي :- 1- بجوار قاعدة البيانات أ - نسخة احتياطية بالتاريخ بفلدر ب- نسخة احتياطية مضغوطة بالتاريخ بفلدر ج - نسخة احتياطية مضغوطة بباسوورد بالتاريخ بفلدر 2- بمسار تختاره أ - نسخة احتياطية ب- نسخة احتياطية مضغوطة ج - نسخة احتياطية مضغوطة بباسوورد فاصيل المكتبات المستخدمة في الكود: FileDialog: جزء من مكتبة Microsoft Office xx.0 Object Library. يسمح بفتح مربع حوار لتحديد الملفات أو المجلدات. CreateObject: جزء من مكتبة OLE Automation. يستخدم لإنشاء كائنات خارجية، مثل تطبيق Access. DBEngine.CreateDatabase: جزء من مكتبة Microsoft Access xx.0 Object Library. يستخدم لإنشاء قاعدة بيانات Access. إذا كانت المكتبات غير مفعلة: إذا لم تكن المكتبات المذكورة أعلاه مفعلة، يمكنك تفعيلها يدويًا عن طريق: فتح نافذة المراجع (Tools > References). البحث عن المكتبات المذكورة أعلاه. تفعيلها بوضع علامة صح (✔) بجانبها. اليكم المرفق . CopyDB.rar

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا من طلبك لاكن حاول تجربة هدا Option Explicit Private Const n As Long = 25 Private Const rHeight As Double = 20 Private Const tmps As Integer = 4 Private Const Col As String = "B" Sub PrintWS() Dim lr As Long, i As Long Dim lastCol As Long, OnRng As Range Dim CrWS As Worksheet Dim ColNum As Long Set CrWS = Sheets("Data") Application.ScreenUpdating = False CrWS.ResetAllPageBreaks Application.ActiveWindow.View = xlPageBreakPreview ColNum = CrWS.Range(Col & "1").Column lr = CrWS.Range(Col & CrWS.Rows.count).End(xlUp).Row CrWS.Rows("5:" & lr).RowHeight = rHeight If lr > tmps + n Then For i = tmps + n + 1 To lr Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(tmps, CrWS.Columns.count).End(xlToLeft).Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, ColNum), CrWS.Cells(lr, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) CrWS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 With CrWS.PageSetup .Orientation = xlPortrait: .PaperSize = xlPaperA4 .FitToPagesWide = 1: .FitToPagesTall = False End With Application.ScreenUpdating = True End Sub Test V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته في الجزء الأخير من الكود قم بإظافة هدا 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

السلام عليكم ورحمة الله وبركاته جزاكم الله كل خير لكل من يقوم علي هذا الموقع ودائما نتابعه للاستفادة من استاذتنا جعله الله في ميزان حسناتهم - لديا قاعدة بيانات المشكلة اني عند ادخال منتج معين لفاتورة شراء وليكن مثلا مروحة سقف تورنيدو يكون سعرها 1100 جنيه ، بعد فترة يزيد سعرها الي 1200 جنيه فاضطر الي ادخال صنف جديد واكتب مروحة سقف تورنيدو 2 علشان هذا الصنف له سعراء شراء مختلف عن ماقبله مع انه نفس الصنف ... اريد حل حتي يتوحد اسمه الصنف ويتعدد اسعار الشراء : وان لا يفقد قيمة كل منهم سعر الشراء الذي دخل بيه علي قاعد البيانات حتي استطيع بعد ذلك تحديد او معرفة الربح . بمعني عندما اقوم ببيع مروحة تورنيدو يظهر ليا سعرين وهما 1100 و 1200 مع الكمية واختار بينهم وجزاكم الله كل خير -مرفق قاعدة البيانات مخزن.rar

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.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

السلام عليكم هذا الموقع يساعدكم في كتابة الاكواد https://chat.deepseek.com/ شاهد هذا الفيديو اتمنى لكم الفائدة

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

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

السلام عليكم الموضوع قديم من 2016 لا اعرف ان كان السيد صالح وجد الحل يوجد عدة طرق في جعل النمودج شفاء دون تاثير على مكونات الاخرى كالازرار وليبلات وغيرها فانا من محبي الاكواد البسيطة لان الاكسس لايتحمل والكود يمكن ان تستدعيه من اي نمودج والكـــود عبارة عن موديول بسيط جدا يممكنك استخدامه لاي نمودج تريد لتوضيح فقط لبعض الاخوة كود استدعاء الموديول يجب تغيير لون خلفية نمودج كما موجود في كود ان وضعت لون احمر في الكود فنفس الشيء في خلفية النمودج ويجب ان تكون الصورة بامتداد ( Png,Gif ) مثل الصورة الموجودة في النمودج وليس شرط ان تضع الصورة في نمودج يمكنك من جعل خلفية النمودج صورة فورم شفــاف.accdb

تفضل فكرتي المتواضعة ، حيث سيتم أولاً تحميل أسماء الاستعلامات في الليست بوكس ، وانت تختار ما تريده ، ثم انقر الزر للتصدير :- Private Sub Export_Selected_Queries() Dim xlApp As Object, xlWorkbook As Object, xlWorksheet As Object Dim db As DAO.Database, rs As DAO.Recordset Dim sheetIndex As Integer, colIndex As Integer, rowIndex As Integer Dim filePath As String, queryName As String Dim i As Variant filePath = Application.CurrentProject.Path & "\تقرير_الاكسيل.xlsx" If Me.Que_List.ItemsSelected.Count = 0 Then MsgBox "يرجى تحديد استعلام واحد على الأقل قبل التصدير", vbExclamation + vbMsgBoxRight, "خطأ" Exit Sub End If Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True Set xlWorkbook = xlApp.Workbooks.Add Set db = CurrentDb sheetIndex = 1 For Each i In Me.Que_List.ItemsSelected queryName = Trim(Me.Que_List.ItemData(i)) Set rs = db.OpenRecordset(queryName, dbOpenSnapshot) If sheetIndex <= xlWorkbook.Sheets.Count Then Set xlWorksheet = xlWorkbook.Sheets(sheetIndex) Else Set xlWorksheet = xlWorkbook.Sheets.Add End If xlWorksheet.Name = queryName colIndex = 1 With xlWorksheet For Each fld In rs.Fields .Cells(1, colIndex).Value = fld.Name .Cells(1, colIndex).Font.Bold = True colIndex = colIndex + 1 Next fld rowIndex = 2 Do While Not rs.EOF colIndex = 1 For Each fld In rs.Fields .Cells(rowIndex, colIndex).Value = fld.Value colIndex = colIndex + 1 Next fld rowIndex = rowIndex + 1 rs.MoveNext Loop End With rs.Close sheetIndex = sheetIndex + 1 Next i xlWorkbook.SaveAs filePath xlWorkbook.Close xlApp.Quit On Error Resume Next Set rs = Nothing Set db = Nothing Set xlWorksheet = Nothing Set xlWorkbook = Nothing Set xlApp = Nothing On Error GoTo 0 MsgBox "تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "نجاح العملية" End Sub test.accdb

إليك كود VBA في Excel لتحقيق ذلك، مع شرح تفصيلي: شرح الكود المتغيرات: lastRow: لتحديد آخر صف يحتوي على بيانات في العمود A (يمكنك تغيير العمود حسب الحاجة). i: متغير يستخدم في حلقة التكرار للمرور على الصفوف. endDate: لتخزين تاريخ انتهاء العقد. daysRemaining: لحساب عدد الأيام المتبقية حتى انتهاء العقد. emailAddress: لتخزين عنوان البريد الإلكتروني للشخص المعني. messageBody: لتخزين نص الرسالة. حلقة التكرار: تكرر الحلقة على جميع الصفوف التي تحتوي على بيانات. تفترض أن تاريخ انتهاء العقد موجود في العمود B، وأن عنوان البريد الإلكتروني موجود في العمود C، ونص الرسالة موجود في العمود D. يمكنك تغيير هذه الأعمدة حسب الحاجة. يتم حساب عدد الأيام المتبقية حتى انتهاء العقد باستخدام الدالة DateDiff. إذا كان عدد الأيام المتبقية 60 يومًا أو أقل، يتم تنفيذ الخطوات التالية: جلب عنوان البريد الإلكتروني ونص الرسالة. استخدام CreateObject("Outlook.Application") لإرسال البريد الإلكتروني. تحديد عنوان المرسل إليه، الموضوع، ونص الرسالة. عرض البريد الإلكتروني أو إرساله مباشرةً. إرسال واتساب: تتطلب هذه الخطوة استخدام واجهة برمجة تطبيقات (API) خاصة بـ WhatsApp، حيث لا يوجد طريقة مباشرة لإرسال رسائل WhatsApp باستخدام VBA فقط. يمكنك استخدام خدمات مثل Twilio أو MessageBird أو غيرها لإرسال رسائل WhatsApp عبر API. يجب عليك التسجيل في إحدى هذه الخدمات والحصول على مفتاح API. يمكنك استخدام الدالة CreateObject("MSXML2.XMLHTTP") لإرسال طلب HTTP إلى API الخاص بـ WhatsApp. الكود ملاحظات: تأكد من تغيير أسماء الأعمدة في الكود لتتوافق مع بياناتك. لتفعيل إرسال الايميل يجب تفعيل المكتبة الخاصة ب outlook من قائمة tools ثم references ثم اختيار Microsoft outlook Object Library. لإرسال رسائل WhatsApp، ستحتاج إلى إضافة كود إضافي باستخدام API. يمكنك تخصيص نص الرسالة وموضوع البريد الإلكتروني حسب الحاجة. يمكنك جدولة تشغيل هذا الكود تلقائيًا باستخدام وظيفة "جدولة المهام" في Windows. إضافة كود لإرسال رسائل WhatsApp باستخدام API يتطلب بعض الخطوات الإضافية. إليك شرح لكيفية القيام بذلك باستخدام خدمة Twilio، وهي واحدة من الخدمات الشائعة التي توفر واجهة برمجة تطبيقات (API) لإرسال رسائل WhatsApp: 1. التسجيل في Twilio والحصول على مفتاح API: قم بزيارة موقع Twilio وقم بإنشاء حساب. بعد تسجيل الدخول، انتقل إلى وحدة تحكم Twilio واحصل على مفتاح API الخاص بك (Account SID وAuth Token). قم بتمكين WhatsApp في حساب Twilio الخاص بك. احصل على رقم هاتف Twilio يدعم WhatsApp. 2. إضافة مكتبة MSXML2: في محرر VBA، انتقل إلى "Tools" ثم "References". ابحث عن "Microsoft XML, v6.0" أو إصدار أحدث وقم بتحديده. 3. كود VBA لإرسال رسالة WhatsApp: Sub SendEmailOrWhatsApp() Dim lastRow As Long Dim i As Long Dim endDate As Date Dim daysRemaining As Long Dim emailAddress As String Dim messageBody As String lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A For i = 2 To lastRow ' ابدأ من الصف الثاني (بافتراض أن الصف الأول هو رأس الجدول) endDate = Cells(i, "B").Value ' تاريخ انتهاء العقد في العمود B daysRemaining = DateDiff("d", Date, endDate) ' حساب الأيام المتبقية emailAddress = Cells(i, "C").Value ' عنوان البريد الإلكتروني في العمود C messageBody = Cells(i, "D").Value ' نص الرسالة في العمود D If daysRemaining <= 60 Then ' إرسال بريد إلكتروني Dim outlookApp As Object Dim outlookMail As Object Set outlookApp = CreateObject("Outlook.Application") Set outlookMail = outlookApp.CreateItem(0) With outlookMail .To = emailAddress .Subject = "تنبيه: انتهاء العقد" .Body = messageBody .Display ' أو .Send للإرسال مباشرةً End With Set outlookMail = Nothing Set outlookApp = Nothing ' إرسال واتساب (يتطلب استخدام API) ' يمكنك إضافة كود لإرسال واتساب هنا باستخدام API End If Next i End Sub Sub SendWhatsAppMessage(phoneNumber As String, messageBody As String) Dim xmlHttp As Object Dim accountSid As String Dim authToken As String Dim twilioNumber As String Dim url As String accountSid = "ACxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' استبدل بـ Account SID الخاص بك authToken = "your_auth_token" ' استبدل بـ Auth Token الخاص بك twilioNumber = "whatsapp:+1xxxxxxxxxx" ' استبدل برقم Twilio الخاص بك phoneNumber = "whatsapp:+xxxxxxxxxxx" ' استبدل برقم هاتف المستلم url = "https://api.twilio.com/2010-04-01/Accounts/" & accountSid & "/Messages.json" Set xmlHttp = CreateObject("MSXML2.XMLHTTP") xmlHttp.Open "POST", url, False xmlHttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(accountSid & ":" & authToken) xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlHttp.send "To=" & phoneNumber & "&From=" & twilioNumber & "&Body=" & EncodeUrl(messageBody) If xmlHttp.Status = 201 Then MsgBox "تم إرسال رسالة WhatsApp بنجاح!" Else MsgBox "فشل إرسال رسالة WhatsApp. الحالة: " & xmlHttp.Status End If Set xmlHttp = Nothing End Sub Function EncodeBase64(text As String) As String Dim arrData() As Byte arrData = StrConv(text, vbFromUnicode) Dim objXML As Object Dim objNode As Object Set objXML = CreateObject("MSXML2.DOMDocument") Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = arrData EncodeBase64 = objNode.text Set objNode = Nothing Set objXML = Nothing End Function Function EncodeUrl(text As String) As String Dim objXML As Object Set objXML = CreateObject("MSXML2.DOMDocument") EncodeUrl = objXML.createElement("url").appendChild(objXML.createTextNode(text)).ParentNode.innerHTML Set objXML = Nothing End Function

تم عمل استعلام موظف Sub بحث_في_السجل() Dim wsSijel As Worksheet, wsBataka As Worksheet Dim startDate As Date, endDate As Date Dim employeeName As String, movementType As String Dim i As Long, j As Long Dim lastRowSijel As Long, lastRowBataka As Long 'تعيين أوراق العمل Set wsSijel = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة 'قراءة قيم البحث من بطاقة الموظف startDate = wsBataka.Range("A2").Value endDate = wsBataka.Range("B2").Value employeeName = wsBataka.Range("C2").Value movementType = wsBataka.Range("D2").Value 'مسح البيانات القديمة في بطاقة الموظف lastRowBataka = wsBataka.Cells(wsBataka.Rows.Count, "A").End(xlUp).Row If lastRowBataka >= 6 Then wsBataka.Range("A6:F" & lastRowBataka).ClearContents End If 'إيجاد آخر صف في شيت السجل lastRowSijel = wsSijel.Cells(wsSijel.Rows.Count, "A").End(xlUp).Row 'البحث في السجل وعرض البيانات في بطاقة الموظف j = 6 'بداية كتابة البيانات في بطاقة الموظف من الصف 6 For i = 2 To lastRowSijel 'بداية البحث من الصف 2 (تخطي العناوين) If wsSijel.Cells(i, 2).Value = employeeName And _ wsSijel.Cells(i, 4).Value = movementType And _ wsSijel.Cells(i, 5).Value >= startDate And _ wsSijel.Cells(i, 5).Value <= endDate Then 'كتابة البيانات في بطاقة الموظف wsBataka.Cells(j, 1).Value = wsSijel.Cells(i, 1).Value 'العمود الأول wsBataka.Cells(j, 2).Value = wsSijel.Cells(i, 2).Value 'اسم الموظف wsBataka.Cells(j, 3).Value = wsSijel.Cells(i, 5).Value 'العمود الثالث wsBataka.Cells(j, 4).Value = wsSijel.Cells(i, 6).Value 'نوع الحركة wsBataka.Cells(j, 5).Value = wsSijel.Cells(i, 7).Value 'التاريخ wsBataka.Cells(j, 6).Value = wsSijel.Cells(i, 8).Value 'العمود السادس wsBataka.Cells(j, 6).NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود j = j + 1 'زيادة الصف لكتابة البيانات في الصف التالي End If Next i MsgBox "تم البحث وعرض البيانات بنجاح." 'Call حساب_مجموع_الساعات Call جمع_الساعات_والدقائق End Sub Sub جمع_الساعات_والدقائق() Dim wsBataka As Worksheet Dim نطاق_الجمع As Range Dim مجموع_الوقت As Double Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة ' تحديد نطاق الجمع (F6 إلى آخر خلية في العمود F) Set نطاق_الجمع = Range("F6", Cells(Rows.Count, "F").End(xlUp)) ' جمع القيم في النطاق مجموع_الوقت = WorksheetFunction.Sum(نطاق_الجمع) ' وضع النتيجة في الخلية E4 Range("E4").Value = مجموع_الوقت ' تنسيق الخلية E4 Range("E4").NumberFormat = "[h]:mm" ' أو "h:mm" حسب الحاجة End Sub الخروج والعودة - كود.xlsm

هل هذا هو المطلوب Sub حساب_فرق_الساعات1() Dim wsData As Worksheet, wsSummary As Worksheet Dim lastRowData As Long, lastRowSummary As Long Dim i As Long, j As Long Dim employeeName As String, movementType As String, movementDate As Date Dim exitTime As Date, returnTime As Date, timeDifference As Double Dim totalHours As Double, days As Long, remainingHours As Long Dim summaryDict As Object 'استخدام Dictionary لتجميع الساعات حسب الموظف والشهر 'تعيين ورقتي العمل Set wsData = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsSummary = ThisWorkbook.Sheets("احتساب عدد الساعات") 'تغيير اسم الورقة حسب الحاجة 'إيجاد آخر صف في ورقة البيانات lastRowData = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row 'إضافة عناوين الأعمدة في ورقة الملخص wsSummary.Cells(1, "A").Value = "اسم الموظف" wsSummary.Cells(1, "C").Value = "نوع الحركة (زمنية)" wsSummary.Cells(1, "D").Value = "إجمالي عدد الساعات" wsSummary.Cells(1, "F").Value = "عدد الأيام والساعات المتبقية" 'إنشاء Dictionary لتجميع الساعات Set summaryDict = CreateObject("Scripting.Dictionary") 'حساب الفرق بين وقت الخروج ووقت العودة For i = 2 To lastRowData employeeName = wsData.Cells(i, "B").Value movementType = wsData.Cells(i, "D").Value movementDate = wsData.Cells(i, "E").Value exitTime = wsData.Cells(i, "F").Value returnTime = wsData.Cells(i, "G").Value 'تأكد من وجود وقت خروج ووقت عودة If IsDate(exitTime) And IsDate(returnTime) Then timeDifference = returnTime - exitTime wsData.Cells(i, "H").Value = timeDifference wsData.Cells(i, "H").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تجميع الساعات إذا كانت الحركة "زمنية" If movementType = "زمنية" Then Dim key As String key = employeeName ' استخدام اسم الموظف فقط كمفتاح If summaryDict.Exists(key) Then summaryDict(key) = summaryDict(key) + timeDifference Else summaryDict(key) = timeDifference End If End If End If Next i 'كتابة ملخص الساعات في ورقة الملخص j = 2 Dim key1 As Variant For Each key1 In summaryDict.Keys employeeName = key1 ' استخدام المفتاح مباشرةً كاسم الموظف totalHours = summaryDict(key1) 'كتابة البيانات في ورقة الملخص wsSummary.Cells(j, "A").Value = employeeName wsSummary.Cells(j, "C").Value = "زمنية" wsSummary.Cells(j, "D").Value = totalHours wsSummary.Cells(j, "D").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تحويل الساعات إلى أيام وساعات days = Int(totalHours * 24 / 24) remainingHours = (totalHours * 24) Mod 24 wsSummary.Cells(j, "F").Value = days & " يوم " & remainingHours & " ساعة" j = j + 1 Next key1 MsgBox "تم حساب الفرق بين وقت الخروج ووقت العودة وتلخيص الساعات بنجاح." End Sub الخروج والعودة - كود.xlsm

وعليكم السلام تم تعديل المعادلة في العمود F تعديل معادلة1.xlsm

أما بالنسبة للطلب نسخة مضغوطة .... ونسخة مضغوطة بباسوورد ..... سأنشرها بمشارك جديدة كهدية لينتفع بها الجميع .

نفضل استاذ @تامر خليفه يالاستعانة بكود أحد الزملاء للاسف مادري اسمه ممكن يكون من النت أو من المنتدى . علما بأني أعمل على اوفيس 2010 32 بت .... اليك المرفق . QR_Code.rar

علي حد ما فهمت من سؤال حضرتك ان ده مخزن و بنضيف فيه من خلال الشراء و نصرف من خلال البيع حضرتك في الحاله دي هتدخل السعر في فواتير الشراء بشكل حر و كذلك البيع طيب حضرتك عاوز تعرف حجم الربح محاسبيا فيه اكتر من طريقه منها الداخل اولا يصرف اولا FIFO او الداخل اخيرا يصرف اولا LIFO ودول صعب تنفيذهم علي السيستم " يعني عاوز حد من العباقره هنا يساعدنا فيه " او المتوسط الحسابي AVERAGE وده اسهل طريقه علشان تعرف الربح لكل المنتجات بمعني حضرتك هتجيب متوسط سعر الشراء لكل صنف وتحسب من خلال الربح

لا تحدها في جدول الأصناف = أين سيتم تحديد سعر الصنف اذاً عند ادخال فاتورة الشراء لأصناف محددة مثلاً !!!!!!! كلا ، أخالفك الرأي في هذه الفكرة ، فجدول الفواتير حسب تصوري سيقوم باضافة اسم الصنف وسعر شراءه وبيعه من جدول الأصناف ، اي في جدول مستقل ، وهنا لن يتم تغيير السعر على جميع الفواتير السابقة !!! سنعود الى فاتورة الشراء والتي من خلالها سيكون عليك اضافة الأصناف التي تم شرائها لاحقاً !!! صحيح ؟؟ 100% لا شك في هذا .

السلام عليكم و رحمة الله و بركاته في مثال الأخير لاستاذ/ أبو خليل جربت حجز فترة تنتهي قبل إنتهاء حجز زبون من بعده مثلا حسن 1 قام بحجز من ساعة 2 مساءً حتى 4 مساءً ثم جاء حسن 2 يريد حجز من ساعة 1 و لمدة 4 ساعات و عند ضغط على الزر حجز يعرض رسالة خطاء و بعد الغاء رسالة ثم ضغط على زر حجز مرة اخرى، يقبل الحجز كما في صورة

نعم أخي فقط قم بتعديل السطور التالية With tbl .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter .Rows.Alignment = wdAlignRowCenter .Borders.Enable = True Dim ColArr As Variant: ColArr = Array(80, 80, 200, 80, 80) For i = 0 To UBound(ColArr) .Columns(i + 1).PreferredWidth = ColArr(i) Next i End With تم تعديل الكود على الملف المرفق مع إظافة إمكانية حفظ الملف بصيغة PDF عند الحاجة ملف تصدير V4.xlsm

وعليكم السلام ورحمة الله نعالى وبركاته يمكنك الإعتماد على ورقة مخفية ضمن المصنف لترحيل البيانات المطلوبة إليها وحفظها مباشرة بصيغة Word Option Explicit Private Const DocName As String = "التوكيلات" Private Const FolderName As String = "ملفات Word" Sub ExportToWord() Dim CrWS As Worksheet, dest As Worksheet, a As Variant, b As Variant Dim lastRow As Long, i As Long, savePath As String, xPath As String Dim wdApp As Object, wdDoc As Object, tbl As Object, d As Object, OnRng As Range Application.ScreenUpdating = False Set CrWS = Sheets("صلاحيات رواكد"): Set dest = Sheets("WordCopy"): Set d = CreateObject("Scripting.Dictionary") dest.Visible = xlSheetVisible a = CrWS.Range("A1:H" & CrWS.Cells(Rows.Count, 1).End(xlUp).Row).Value dest.Range("A1:E" & dest.Rows.Count).ClearContents For i = LBound(a) To UBound(a): d(i) = Array(a(i, 1), a(i, 3), a(i, 4), a(i, 6), a(i, 8)): Next i b = Application.Transpose(Application.Transpose(d.items)): dest.Range("A1").Resize(UBound(b), UBound(b, 2)) = b lastRow = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row Set OnRng = dest.Range("A1:E" & lastRow) With OnRng .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Set wdApp = CreateObject("Word.Application"): wdApp.Visible = True: Set wdDoc = wdApp.Documents.Add wdDoc.PageSetup.Orientation = 1: OnRng.Copy: wdDoc.Content.Paste: Set tbl = wdDoc.Tables(1) With tbl: .Range.ParagraphFormat.Alignment = 1: .Borders.Enable = True Dim ColArr As Variant: ColArr = Array(110, 110, 250, 110, 110) For i = 0 To UBound(ColArr): .Columns(i + 1).PreferredWidth = ColArr(i): Next i End With With tbl.Rows.Add .Cells(4).Range.Text = ": المجموع": .Cells(5).Range.Text = Application.Sum(dest.Range("E2:E" & lastRow)) With .Cells(4).Range: .Font.Color = RGB(255, 0, 0): .ParagraphFormat.Alignment = 1: End With .Cells(5).Range.Font.Color = RGB(255, 0, 0): .Cells(5).Range.Font.Bold = True .Cells(1).Merge tbl.Rows(tbl.Rows.Count).Cells(4) End With xPath = ThisWorkbook.Path & "\" & FolderName If Dir(xPath, vbDirectory) = "" Then MkDir xPath savePath = xPath & "\" & DocName & ".docx" On Error Resume Next wdDoc.SaveAs savePath If Err.Number <> 0 Then MsgBox "الملف مفتوح بالفعل حاول إغلاقه والمحاولة مرة أخرى ", vbCritical wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing Exit Sub End If On Error GoTo 0 wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing dest.Visible = xlSheetVeryHidden: Set dest = Nothing Application.ScreenUpdating = True MsgBox "تم تصدير البيانات بنجاح" End Sub ملف تصدير V2.xlsm

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

تفضل استاذ @رشبد طلبك حسب مافهمت . ووافني بالرد . ويمكن اضافة اختيارين كمان ... 1- نسخة مضغوطه .... 2- نسخة مضغوطة بباسوورد . CopyDB.rar

هذا البرنامج وصلني بالأمس من احد الاصدقاء من دولة العراق الشقيق وهو مفتوح المصدر ومقدم هدية الرقم السري للدخول الى الاكواد 12345 معلومات المبرمج موجوده على الشاشة الرئيسية حفاظا على حقوقه في التصميم اتمنى لكم الفائدة حجم البرنامج كبير لم اتمكن من رفعه حتى وهو مضغوط سأرفعه على جوجل درايف https://drive.google.com/file/d/1gUC2Q6jMxPsoHXzcCAPq0hPXLKhsGvjo/view?usp=sharing

ومشاركة مع الأستاذ @عبد اللطيف سلوم ، هذه فكرتي ، الدالة التالية Function ToggleAMPM(timeValue As Date) As Date If Format(timeValue, "AM/PM") = "AM" Then ToggleAMPM = DateAdd("h", 12, timeValue) Else ToggleAMPM = DateAdd("h", -12, timeValue) End If End Function time.accdb

أخي عبداللطيف النسخ الاحتياطي قائم على فكرة نسخ > لصق القاعدة 🙂

وعليكم السلام ورحمة الله وبركاته تم حساب المطلوب بالمعادلات تفضل test002.xlsx

متابع 😇

السلام عليكم مشاركه مع اخوتى واساتذتى اعجبتنى طريقه اخى الفاضل @Foksh جزاه الله خيرا وقمت بالتعديل عليها لان الخطأ الذى ظهر للاستاذ عبداللطيف بسبب ان التوقيت فى صباحا ومساء بالعربى وعند اخى فادى بالانجليزى وهذا ما احدث الخطأ فقمت بالتعديل عليها حيث تعلمت الطريقه من اخى فاضل هنا بالمنتدى جزاه الله عنا كل خير Private Sub Command7_Click() Dim rs As DAO.Recordset Dim sql As String sql = "SELECT 1 FROM Tbl_Party WHERE DATE_PARTY = #" & Me.DATE_PARTY & "# " & _ "AND ((" & CDbl(Me.TIME_PARTY_START) & " BETWEEN cdbl(TIME_PARTY_START) AND cdbl(TIME_PARTY_END)) " & _ "OR (" & CDbl(Me.TIME_PARTY_END) & " BETWEEN cdbl(TIME_PARTY_START) AND cdbl(TIME_PARTY_END)) " & _ "OR (cdbl(TIME_PARTY_START) BETWEEN " & CDbl(Me.TIME_PARTY_START) & " AND " & CDbl(Me.TIME_PARTY_END) & "))" Set rs = CurrentDb.OpenRecordset(sql, dbOpenSnapshot) If Not rs.EOF Then MsgBox "يوجد حجز مسبق لهذه الفترة!", vbExclamation, "تنبيه" Else CurrentDb.Execute "INSERT INTO Tbl_Party (DATE_PARTY, TIME_PARTY_START, TIME_PARTY_END) " & _ "VALUES (#" & Me.DATE_PARTY & "#, #" & Me.TIME_PARTY_START & "#, #" & Me.TIME_PARTY_END & "#)", dbFailOnError MsgBox "تم حفظ الحجز بنجاح!", vbInformation, "تأكيد" End If rs.Close: Set rs = Nothing End Sub تمنياتى لكم بالتوفيق WEEDING HALLS_1.accdb