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

السلام عليكم ورحمة الله تعالى وبركاته استكمالا لسلسلة الافكار المطروحة للنقاش والتى اتمنى ان اجد فيها تفاعلا بالنقاش وابداء الرأى اليوم اقدم لكم التالى الكود يهدف إلى إدارة الحقول والجداول في قاعدة بيانات يتضمن الكود مجموعة من الإجراءات التي تمكن المستخدم من: إنشاء الجداول و الحقول في الجداول وتحديث خصائص الحقول مثل التسمية والوصف ويمكن إضافة البيانات إلى الجداول بشكل اختياري الى الحقول كذلك اذا استدعت الحاجة الى ذلك كما يتيح الكود إضافة الحقول إلى الجداول إذا كانت غير موجودة أو تحديث البيانات داخل الحقول فى الجداول إذا كانت موجودة يتم أيضًا دعم الحقول المتعددة الخيارات (MultipleChoice) من خلال التعداد FieldsTypes يتم استخدام القاموس لتخزين الحقول ومعلوماتها، مما يتيح تنظيم البيانات بشكل مرن يضمن الكود تحديث الجداول وإضافة الحقول والخصائص بشكل ديناميكي، مع إمكانية إضافة البيانات إذا كانت مطلوبة الكود الرئيسي استخدام القواميس Dictionary بدون الحاجة إلى تفعيل مكتبة Microsoft Scripting Runtime حتى لا يتوقف الكود عن العمل فى حال نقل الموديول الى قاعدة اخرى بدون تفعيل المكتبة الموديول الرئيسي : Option Compare Database Option Explicit ' تعريف تعداد لأنواع الحقول Public Enum FieldsTypes dbBoolean = 1 ' نوع الحقل: Boolean (قيمة منطقية: صحيح أو خطأ) dbByte = 2 ' نوع الحقل: Byte (عدد صحيح صغير بين 0 و 255) dbInteger = 3 ' نوع الحقل: Integer (عدد صحيح بين -32,768 و 32,767) dbLong = 4 ' نوع الحقل: Long (عدد صحيح طويل بين -2,147,483,648 و 2,147,483,647) dbCurrency = 5 ' نوع الحقل: Currency (عدد عشري بدقة عالية لاستخداماته المالية) dbSingle = 6 ' نوع الحقل: Single (عدد عشري دقيق، ولكنه أقل دقة من Double) dbDouble = 7 ' نوع الحقل: Double (عدد عشري بدقة مزدوجة) dbDate = 8 ' نوع الحقل: Date (تاريخ/وقت) dbText = 10 ' نوع الحقل: Text (نص عادي يمكن تخزينه في الحقل) dbLongBinary = 11 ' نوع الحقل: Long Binary (بيانات ثنائية كبيرة الحجم) dbMemo = 12 ' نوع الحقل: Memo (نص طويل جدًا يمكن أن يحتوي على عدة آلاف من الأحرف) dbGUID = 15 ' نوع الحقل: GUID (معرف فريد عالميًا) dbBigInt = 16 ' نوع الحقل: Big Int (عدد صحيح كبير جدًا) dbVarBinary = 17 ' نوع الحقل: VarBinary (بيانات ثنائية متغيرة الحجم) dbNumeric = 19 ' نوع الحقل: Numeric (عدد عشري يستخدم عادة في الحسابات الدقيقة) dbMultipleChoice = 20 ' نوع الحقل: MultipleChoice (دعم الحقول متعددة الخيارات) dbAutoNumber = 21 ' نوع الحقل: AutoNumber (ترقيم تلقائي) End Enum ' متغير عام لتخزين الحقول باستخدام القاموس Public Fields As Object ' هذا الإجراء يقوم بإضافة حقل جديد إلى القاموس الذي يحتوي على الحقول المختلفة Public Sub AddFieldToDictionary(fieldName As String, _ fieldType As FieldsTypes, _ Optional fieldCaption As String = "", _ Optional fieldDescription As String = "", _ Optional defaultValue As Variant = Null _ ) ' إنشاء قاموس جديد لتخزين معلومات الحقل Dim fieldDict As Object Set fieldDict = CreateDictionary() ' إضافة الحقول إلى القاموس fieldDict("Name") = fieldName ' اسم الحقل fieldDict("Type") = fieldType ' نوع الحقل (من تعداد FieldsTypes) fieldDict("Caption") = fieldCaption ' التسمية التي تظهر في واجهة المستخدم (اختياري) fieldDict("Description") = fieldDescription ' وصف الحقل (اختياري) fieldDict("DefaultValue") = defaultValue ' القيمة الافتراضية (اختياري) ' التحقق مما إذا كان القاموس فارغًا، وإذا كان كذلك يتم تهيئته باستخدام قاموس جديد If Fields Is Nothing Then Set Fields = CreateObject("Scripting.Dictionary") ' إضافة القاموس الخاص بالحقل إلى القاموس العام باستخدام اسم الحقل كمفتاح Set Fields(fieldName) = fieldDict End Sub ' هذه الدالة تقوم بإنشاء قاموس جديد عند الحاجة إليها Public Function CreateDictionary() As Object ' إنشاء قاموس جديد باستخدام "Scripting.Dictionary" Set CreateDictionary = CreateObject("Scripting.Dictionary") End Function ' هذه الدالة تقوم بالتحقق إذا كان الجدول المطلوب موجودًا في قاعدة البيانات Public Function TableExists(tableName As String) As Boolean Dim tdf As DAO.TableDef ' استعراض جميع الجداول في قاعدة البيانات For Each tdf In CurrentDb.TableDefs ' إذا كان اسم الجدول يتطابق مع الاسم المطلوب If tdf.Name = tableName Then '(الجدول موجود) إذا تم العثور على الجدول TableExists = True Exit Function End If Next tdf '(الجدول غير موجود) إذا لم يتم العثور على الجدول TableExists = False End Function ' هذا الإجراء يقوم بإنشاء الجدول إذا لم يكن موجودًا أو تحديثه إذا كان موجودًا Public Sub CreateTable(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() Set tdf = db.CreateTableDef(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' إضافة الحقول إلى الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إنشاء حقل جديد في الجدول If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If ' إذا كان هناك قيمة افتراضية يتم إضافتها If fieldDict.Exists("DefaultValue") And Not IsNull(fieldDict("DefaultValue")) Then fld.defaultValue = fieldDict("DefaultValue") End If ' إضافة الحقل إلى الجدول tdf.Fields.Append fld Next key ' إضافة الجدول إلى قاعدة البيانات db.TableDefs.Append tdf db.TableDefs.Refresh Application.RefreshDatabaseWindow ' تحرير المتغيرات Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub ' هذه الدالة تقوم بالتحقق من وجود الحقل في الجدول Public Function FieldExists(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 FieldExists = True Exit Function End If Next fld ' الحقل غير موجود FieldExists = False End Function ' هذا الإجراء يقوم بإضافة الحقول إلى الجدول إذا لم تكن موجودة Public Sub AddFieldsIfNeeded(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 ' البحث عن أول حقل من النوع AutoNumber في القاموس For Each key In Fields.Keys Set fieldDict = Fields(key) ' التحقق من عدم وجود حقل بنفس الاسم If Not FieldExists(tdf, fieldDict("Name")) Then If fieldDict("Type") <> dbAutoNumber Then Set fld = tdf.CreateField(fieldDict("Name"), fieldDict("Type")) Else Set fld = tdf.CreateField(fieldDict("Name"), dbLong) fld.Attributes = dbAutoIncrField End If tdf.Fields.Append fld End If Next key End Sub ' هذا الإجراء يقوم بإضافة خصائص الحقول في الجدول Public Sub AddFieldProperties(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() Set tdf = db.TableDefs(tableName) ' التأكد من أن القاموس غير فارغ If Fields Is Nothing Then Exit Sub ' استعراض الحقول في القاموس وتحديث خصائصها في الجدول For Each key In Fields.Keys Set fieldDict = Fields(key) ' إذا كان الحقل موجودًا في الجدول، يتم تحديث خصائصه If FieldExists(tdf, fieldDict("Name")) Then Set fld = tdf.Fields(fieldDict("Name")) ' إضافة أو تحديث التسمية ( عنوان الحقل/التسمية التي تظهر في واجهة المستخدم ) إذا كانت موجودة If fieldDict.Exists("Caption") And fieldDict("Caption") <> "" Then On Error Resume Next fld.Properties("Caption") = fieldDict("Caption") If Err.Number <> 0 Then Err.Clear Set prop = fld.CreateProperty("Caption", dbText, fieldDict("Caption")) fld.Properties.Append prop End If On Error GoTo 0 End If ' إضافة أو تحديث الوصف (الوصف) إذا كان موجودًا If fieldDict.Exists("Description") And fieldDict("Description") <> "" Then On Error Resume Next fld.Properties("Description") = fieldDict("Description") If Err.Number <> 0 Then Err.Clear Set prop = fld.CreateProperty("Description", dbText, fieldDict("Description")) fld.Properties.Append prop End If On Error GoTo 0 End If End If Next key End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه وإضافة البيانات إذا كانت موجودة Public Sub CreateOrUpdateTable(tableName As String, Fields As Object) Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb() If Not TableExists(tableName) Then CreateTable tableName, Fields Else Set tdf = db.TableDefs(tableName) AddFieldsIfNeeded tdf, Fields End If AddFieldProperties tableName, Fields Application.RefreshDatabaseWindow End Sub ' هذا الإجراء يقوم بإنشاء الجدول أو تحديثه بالإضافة إلى إضافة البيانات إذا كانت موجودة Public Sub CreateOrUpdateTableAndAddData(tableName As String, _ Fields As Object, _ Optional fieldValues As Object, _ Optional bAddData As Boolean = False _ ) Dim db As DAO.Database Dim tdf As DAO.TableDef Dim rst As DAO.Recordset Dim key As Variant Dim fieldValue As Variant Dim isEmpty As Boolean Dim fieldName As String Set db = CurrentDb() If Not TableExists(tableName) Then CreateTable tableName, Fields Else Set tdf = db.TableDefs(tableName) AddFieldsIfNeeded tdf, Fields End If ' إضافة البيانات إذا كانت القيمة للعلم صحيحة If bAddData Then Set rst = db.OpenRecordset(tableName, dbOpenDynaset) isEmpty = (rst.RecordCount = 0) If isEmpty Then rst.AddNew For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) rst(fieldName) = fieldValue Next key rst.Update Else rst.MoveFirst For Each key In fieldValues.Keys fieldName = key fieldValue = fieldValues(key) If IsNull(rst(fieldName)) Or (rst(fieldName) <> fieldValue) Then rst.Edit rst(fieldName) = fieldValue rst.Update End If Next key End If End If ' إضافة خصائص الحقول للجدول المحدد AddFieldProperties tableName, Fields ' تحديث نافذة قاعدة البيانات Application.RefreshDatabaseWindow End Sub لاستدعاء الكود بدون اضافة اى بيانات داخل الحقول ' هذا الإجراء يقوم بتهيئة الجدول فقط بدون البيانات الخاصة بالتصميم Public Sub SetupDesignerTableOnly() Dim tblName As String tblName = "UsysTblDesignerInformation" Set Fields = CreateDictionary() ' إضافة الحقول و معلومات كل حقل " اسم الحقل - نوع الحقل -التسمية التي تظهر في واجهة المستخدم (اختياري) - وصف الحقل (اختياري) - القيمة الافتراضية (اختياري) AddFieldToDictionary "ID", dbAutoNumber, "ID", "المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, "Designer Platform", "اسم المنصة" AddFieldToDictionary "FullName", dbText, "Full Name", "الاسم الكامل" AddFieldToDictionary "Email", dbText, "Email Address", "البريد الإلكتروني" AddFieldToDictionary "PhoneNumber", dbText, "Phone Number", "رقم الهاتف" AddFieldToDictionary "DesignSpecialty", dbText, "Design Specialty", "مجال التخصص" AddFieldToDictionary "PortfolioLink", dbText, "Portfolio Link", "رابط المحفظة" AddFieldToDictionary "CreationDate", dbDate, "Creation Date", "تاريخ التسجيل", "NOW()" ' إنشاء أو تحديث الجدول بالإضافة إلى إضافة البيانات CreateOrUpdateTableAndAddData tblName, Fields End Sub لاستدعاء الكود مع اضافة بيانات اجبارية للجداول ذات السجل الواحد مثلا كبيانات التطبيق او بيانات المصمم على سبيل المثال وليس الحصر ' هذا الإجراء يقوم بتهيئة البيانات الخاصة بالتصميم Public Sub SetupDesignerData() Dim fieldValues As Object Dim tblName As String tblName = "UsysTblDesignerInformation" Set Fields = CreateDictionary() Set fieldValues = CreateDictionary() ' إضافة الحقول و معلومات كل حقل " اسم الحقل - نوع الحقل -التسمية التي تظهر في واجهة المستخدم (اختياري) - وصف الحقل (اختياري) - القيمة الافتراضية (اختياري) AddFieldToDictionary "ID", dbAutoNumber, "ID", "المعرف (التلقائي)" AddFieldToDictionary "DesignerPlatform", dbText, "Designer Platform", "اسم المنصة" AddFieldToDictionary "FullName", dbText, "Full Name", "الاسم الكامل" AddFieldToDictionary "Email", dbText, "Email Address", "البريد الإلكتروني" AddFieldToDictionary "PhoneNumber", dbText, "Phone Number", "رقم الهاتف" AddFieldToDictionary "DesignSpecialty", dbText, "Design Specialty", "مجال التخصص" AddFieldToDictionary "PortfolioLink", dbText, "Portfolio Link", "رابط المحفظة" AddFieldToDictionary "CreationDate", dbDate, "Creation Date", "تاريخ التسجيل", "NOW()" ' إضافة القيم الخاصة لكل حقل fieldValues("DesignerPlatform") = "Example Designer Platform™" fieldValues("FullName") = "Example Designer Name" fieldValues("Email") = "example.designer@email.com" fieldValues("PhoneNumber") = "+000 Example Designer Phone Number" fieldValues("DesignSpecialty") = "Example Designer Specialty" fieldValues("PortfolioLink") = "https://example.com/designer-portfolio" fieldValues("CreationDate") = Now ' إنشاء أو تحديث الجدول بالإضافة إلى إضافة البيانات CreateOrUpdateTableAndAddData tblName, Fields, fieldValues, True End Sub وكما ذكرت الموضوع مطروح للتجربة والنقاش .... اتمنى وارجوا من حضراتكم التفاعل بالنقاش وابداء الرأى

UPDATE [ارقام مسلسله] SET [مسلسل] = IIf( InStr([مسلسل], "/2024") > 0, Left([مسلسل], Len([مسلسل]) - 5) & "/" & Year(Date()), [مسلسل] ) ولكن هذا افضل ليه إذا كان الحقل "مسلسل" يحتوي على أكثر من شريط مائل / في النص فإن : InStr([مسلسل], "/") سوف يعيد موضع أول شريط مائل فقط في هذه الحالة سيتغير الجزء الأيسر ولكن لن يتم استبدال السنة بشكل صحيح إذا كان هناك شرطة مائلة آخري الصح وانت تضع حل مشكله توقع الاخطاء التى قد تصادفها وتسبب خطأ فى حل المشكله

مشاركة مع الأستاذ @kanory UPDATE [ارقام مسلسله] SET مسلسل = Left([مسلسل], InStr([مسلسل], "/") - 1) & "/" & Year(Date()); اذا كنت تريد استخدام هذا الإجراء بشكل سنوي لتحديث قيمة السنة 🤗 . عذراً ، لم انتبه لمشاركة الأستاذ @سامي الحداد 🤗 .

هذا بسبب المتغيرات غير المعلنة المشكلة انه يتم استخدام المتغيرات دون الإعلان عنها باستخدام Dim أو Public أو Private. قم بتعريف كافة المتغيرات قبل استخدامها تحقق من وجود متغيرات غير معلنة، وأخطاء مطبعية، يمكنك استخدام Debug.Print لمعرفة اين الخطاء وايضا في محرر الاكواد استخدم Debug → Compile واليك تعديل بسيط للكود ولكن تأكد اولا من كل المتغيرات في برنامجك. Option Compare Database Option Explicit Private Sub Kind_AfterUpdate() Dim frm As Form If Not IsNull(Me.Kind) Then Set frm = Me.AGR.Form frm!Kind = Nz(Me.Kind, "") Set frm = Nothing End If End Sub بالتوفيق

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

الأخ عبدالله جرب الملف وكل شيء طبيعي لم تظهر لي المشلكلة التي ظهرت عند الأخ أبوحمادة

ليس صحيحاً أخي الكريم ,,, انظر المرفق modif.accdb

حفظك الله وزادك علما وفضلا اطلع على هذا التعديل Database1.rar

هذا قد يعني ان الجزء المسؤول عن اضافة القيمة الى الحقل تشوبه شائبة ، وأنا لا أحب التفكير في المكونات الغير صرورية 😁

الظاهر اننا كنا نكتب في نفس الوفت استادي الفاضل فادي تحياتي لك.

وهذه مشاركتي بالنسبة لــــ كود استعلام التحديث UPDATE [ارقام مسلسله] SET مسلسل = Left([مسلسل], InStr([مسلسل], "/") - 1) & "/" & Year(Date()); ونصيحة نكررها داىما ابتعد عن المسميات باللغة العربية. بالتوفيق

وعليكم السلام ورحمة الله جرب الكود التالي Sub UpdateSerialNumbers() Dim db As DAO.Database Dim sql As String Dim currentYear As String ' الحصول على السنة الحالية من نظام الكمبيوتر currentYear = Year(Date) ' إنشاء استعلام التحديث sql = "UPDATE [أرقام مسلسلة] " & _ "SET مسلسل = Left(مسلسل, InStr(مسلسل, '/') - 1) & '/" & currentYear & "'" ' فتح قاعدة البيانات وتنفيذ الاستعلام Set db = CurrentDb db.Execute sql, dbFailOnError ' تنظيف الذاكرة Set db = Nothing ' إظهار رسالة تأكيد MsgBox "تم تحديث أرقام المسلسل إلى سنة " & currentYear, vbInformation, "تحديث ناجح" End Sub شرح الكود: يحصل على السنة الحالية من النظام. ينشئ استعلام تحديث يستبدل الجزء الأيمن (/2024) بالسنة الجديدة. يستخدم دالة Left() لاستخراج الجزء الأيسر من السلسلة النصية قبل العلامة /، ثم يضيف /السنة الجديدة. ينفذ التحديث عبر db.Execute. يعرض رسالة تأكيد بعد انتهاء العملية. طريقة الاستخدام: يمكنك تشغيل هذا الكود من خلال زر في نموذج، بإضافة زر وتنفيذ الإجراء عند النقر عليه. أو تشغيله يدويًا من نافذة VBA. طريقة استخدام الكود انشئ زر وضع فيه Call UpdateSerialNumbers

بارك الله فيك ونفع بك ... المثال شغال 100%

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

السلام عليكم مشاركة مع الاساتدة بدون استعلام Private Sub Kind_AfterUpdate() Dim frm As Form If Not IsNull(Me.kind) Then Set frm = Me!AGR.Form frm!kind = Me.kind End If End Sub بالتوفيق Subform (1).accdb

ان توفر الوقت اصحح واستكمل بتعديل الاكواد بنطاق جغرافي 2

الملف السابق به تعديل المدى في الشيتات الثلاتة الاولى الكود السابق يبذأ من الصف 12 والصحيح انه 9 على كل حال الملف المرفق الحالى به زرين الاول الكود الاول مع التعديل والزر الاخر الكود بالمصفوفة وكلاهما سريعين جدا ترحيل الدرجات1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub addbtn_Click() Dim n As Long Dim src As Worksheet: Set src = Sheets("Data") n = Application.WorksheetFunction.CountA(src.Range("B:B")) + 1 If Me.studname = "" Then: Exit Sub src.Cells(n, 2) = Me.cod.Value src.Cells(n, 3) = Me.studname.Value src.Cells(n, 4) = Me.row.Value src.Cells(n, 5) = Me.class.Value src.Cells(n, 6) = Me.group.Value src.Cells(n, 7) = Me.studcase.Value src.Cells(n, 8) = Me.birthdate.Value src.Cells(n, 9) = Me.mother.Value src.Cells(n, 10) = Me.gender.Value src.Cells(n, 11) = Me.mobile.Value src.Cells(n, 12) = Me.subcase.Value src.Cells(n, 13) = Me.adress.Value src.Cells(n, 14) = Me.datenow.Value src.Cells(n, 15) = Me.employ.Value src.Cells(n, 16) = Me.notes.Value With src.Range("A2:A" & src.Cells(src.Rows.Count, "B").End(xlUp).row) .Value = Evaluate("ROW(" & .Address & ")") End With arr = Array("studname", "cod", "row", "birthdate", "class", "studcase", "mobile", _ "notes", "group", "mother", "gender", "subcase", "adress") For i = 0 To UBound(arr): Me.Controls(arr(i)).Value = Empty: Next i MsgBox "تمت عملية التسجيل بنجاح" 'ActiveWorkbook.Save End Sub دوبل كليك على الصف الاول من ورقة Data لاظهار اليوزرفورم Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect(Target, Range("A1:P1")) Is Nothing Then Cancel = True ADD.Show End If End Sub school data 2025x V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

جرب هدا Sub PrintArea() Dim F As Worksheet: Set F = Sheet1 Cpt = 18: A = 1: B = 4: C = 1 With F .PageSetup.PrintArea = "" .PageSetup.PrintArea = Range("A1", Cells(46, Cpt)).Address: .PrintOut Copies:=A .PageSetup.PrintArea = Range("A47", Cells(96, Cpt)).Address: .PrintOut Copies:=B .PageSetup.PrintArea = Range("A97", Cells(150, Cpt)).Address: .PrintOut Copies:=C End With End Sub او يمكنك تحديد الصفحات وعدد مرات الطباعة بالاعتماد على ورقة اخرى خاصة بالاعدادات كما في المثال التالي Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1 End Property Public Property Get F() As Worksheet: Set F = Sheet2 End Property Sub To_print() déleteRow TbPage = F.[Tb_MiseEnPage] NbMax = UBound(TbPage) Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم الصفحة المرغوب طباعتها (من 0 الى " & NbMax & ")", Title:="طباعة", Type:=1) Cpt = Int(Cpt) If Cpt < 1 Then Exit Sub If Cpt > NbMax Then: MsgBox " اخر صفحة على الملف هي : " _ & NbMax _ & "", vbExclamation, "المرجوا التحقق من رقم الصفحة المرغوب طباعتها": Exit Sub With Sh_Print .PageSetup.PrintArea = "" For i = 1 To Cpt With .PageSetup On Error Resume Next .PrintArea = TbPage(i, 2) & ":" & TbPage(i, 3): Copies = TbPage(i, 4) If Copies < 1 Then Copies = 1 .FitToPagesWide = 1 .FitToPagesTall = 1 On Error GoTo 0 End With Next End With Sh_Print.PrintOut Copies:=Copies End Sub '*********************************** Sub déleteRow() With F For i = F.[B65000].End(xlUp).Row To 2 Step -1 Application.ScreenUpdating = False If Application.CountA(Range(F.Cells(i, "B"), F.Cells(i, "C"))) = 0 Then F.Rows(i).Delete F.Range("A2:A" & Rows.Count).ClearContents Next i With F.Range("A2:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End With Application.ScreenUpdating = True End Sub نمودج طباعة.xlsm

كانت النتيجة كلها اصفار