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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 3 ، وزر واحد فقط وظائفهم كالآتي :- cmbTable1 : التعرف على أسماء الجداول في قاعدة البيانات ، وهنا سيكون الجدول الأول . cmbTable2 : التعرف على أسماء الجداول في قاعدة البيانات باستثناء الجدول الذي تم اختياره في cmbTable1 ؛ والهدف هو عمل مقارنة بين جدولين وليس نفس الجدول . cmbPrimaryField : التعرف على أسماء الحقول في الجدول الأول ، ثم يتم اختيار الحقل المشترك أو المفتاح الأساسي من طرف المستخدم . btnExecute : منفّـذ العملية . ⭐ الأحداث والأكواد لكل جزء و عنصر في البرنامج :- في حدث عند التحميل للنموذج ، تم وضع الكود التالي لجلب أسماء الجداول إلى الكومبوبوكس ( cmbTable1 و cmbTable2 ) ، وطبعاً سيتم استثناء جداول النظام والجدول DifferencesTable الذي سيتم إدراج التغييرات فيه ( والذي سيتم انشائه بشكل ديناميكي في قاعدة البيانات عند المستخدم عند عدم وجوده ) . أي أنه وللإستفادة من البرنامج ما عليك إلا نسخ النموذج فقط الى مشروعك . Private Sub Form_Load() Me.cmbTable2.Enabled = False Me.cmbPrimaryField.Enabled = False Dim tdf As DAO.TableDef Me.cmbTable1.RowSource = "" Me.cmbTable2.RowSource = "" For Each tdf In CurrentDb.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" Then Me.cmbTable1.AddItem tdf.Name 'Me.cmbTable2.AddItem tdf.Name End If Next tdf End Sub في حدث بعد التحديث للكومبوبوكس cmbTable1 ، سيتم إدراج أسماء الجداول المتبقية كما ذكرت سابقاً في الكومبوبوكس cmbTable2 باستثناء ما تم اختياره في الجدول cmbTable1 :- Private Sub cmbTable1_AfterUpdate() Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Me.cmbPrimaryField.RowSource = "" Set db = CurrentDb Set tdf = db.TableDefs(Me.cmbTable1.Value) For Each fld In tdf.Fields Me.cmbPrimaryField.AddItem fld.Name Next fld Me.cmbTable2.RowSource = "" For Each tdf In db.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" And tdf.Name <> Me.cmbTable1.Value Then Me.cmbTable2.AddItem tdf.Name End If Next tdf Me.cmbTable2.Enabled = True Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub في حدث عند النقر على الزر btnExecute ، سيتم تنفيذ الكود التالي :- Private Sub btnExecute_Click() Dim db As DAO.Database Dim rsOld As DAO.Recordset Dim rsNew As DAO.Recordset Dim rsDifferences As DAO.Recordset Dim fld As DAO.Field Dim recordFound As Boolean Dim commonFields As Collection Dim fieldName As Variant Dim primaryField As String Dim table1 As String Dim table2 As String If IsNull(Me.cmbTable1) Then MsgBox "قم باختيار الجدول الأول", vbCritical, "" Me.cmbTable1.SetFocus Exit Sub ElseIf IsNull(Me.cmbTable2) Then MsgBox "قم باختيار الجدول الثاني", vbCritical, "" Me.cmbTable2.SetFocus Exit Sub ElseIf IsNull(Me.cmbPrimaryField) Then MsgBox "قم باختيار الحقل الأساسي", vbCritical, "" Me.cmbPrimaryField.SetFocus Exit Sub Else table1 = Me.cmbTable1.Value table2 = Me.cmbTable2.Value primaryField = Me.cmbPrimaryField.Value If IsNull(table1) Or IsNull(table2) Or IsNull(primaryField) Then MsgBox "Please select both tables and the primary field." Exit Sub End If Set db = CurrentDb If Not TableExists("DifferencesTable") Then CreateDifferencesTable db End If Set rsOld = db.OpenRecordset(table1) Set rsNew = db.OpenRecordset(table2) Set rsDifferences = db.OpenRecordset("DifferencesTable", dbOpenDynaset) DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM DifferencesTable;" DoCmd.SetWarnings True Set commonFields = New Collection For Each fld In rsOld.Fields On Error Resume Next If Not IsNull(rsNew.Fields(fld.Name).Name) Then If fld.Name <> primaryField Then commonFields.Add fld.Name, fld.Name End If End If On Error GoTo 0 Next fld Do While Not rsOld.EOF recordFound = False rsNew.MoveFirst Do While Not rsNew.EOF If rsOld(primaryField) = rsNew(primaryField) Then recordFound = True For Each fieldName In commonFields If Nz(rsOld(fieldName), "") <> Nz(rsNew(fieldName), "") Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Modification" rsDifferences("FieldName") = fieldName rsDifferences("OldValue") = rsOld(fieldName) rsDifferences("NewValue") = rsNew(fieldName) rsDifferences.Update End If Next fieldName Exit Do End If rsNew.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Deletion" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = "عملية حذف" rsDifferences("NewValue") = Null rsDifferences.Update End If rsOld.MoveNext Loop rsNew.MoveFirst Do While Not rsNew.EOF recordFound = False rsOld.MoveFirst Do While Not rsOld.EOF If rsNew(primaryField) = rsOld(primaryField) Then recordFound = True Exit Do End If rsOld.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsNew(primaryField) rsDifferences("ChangeType") = "Addition" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = Null rsDifferences("NewValue") = "عملية إضافة" rsDifferences.Update End If rsNew.MoveNext Loop rsOld.Close rsNew.Close rsDifferences.Close Set rsOld = Nothing Set rsNew = Nothing Set rsDifferences = Nothing Set db = Nothing End If CreatePivotQuery table1, table2 MsgBox "تمت عملية المقارنة في الجدولين ، وسيتم فتح الاستعلام بالنتائج", vbInformation, "" DoCmd.OpenQuery "Foksh", acViewNormal End Sub الكود يقوم بتنفيذ عملية مقارنة بين بيانات الجدولين ( من خلال اختيار الجدول الأول والجدول الثاني كما ذكرت سابقاً ) في أي قاعدة بيانات للمستخدم . وفيما يلي شرح مبسط للخطوات الرئيسية التي ينفذها هذا الكود ( للفائدة ):- التحقق من القيم في الكومبوبوكسات الثلاثة يتم التحقق مما إذا كان المستخدم قد اختار الجداول الأساسية ( الجدول الأول و الجدول الثاني ) وحقل المفتاح الأساسي للمقارنة . فإذا كانت أي من هذه المدخلات مفقودة أو لم يتم اختياره ، يعرض الكود رسالة تحذير بوجوب اختيار الجدول أو المفتاح الأساسي وبالتالي يوقف العملية . تحضير البيانات يتم فتح السجلات من الجداول المختارة (الجدول الأول والجدول الثاني) وإنشاء سجل جديد في جدول DifferencesTable لتخزين الفروقات والتغيرات . مقارنة البيانات سيقوم الكود بمقارنة السجلات في الجدولين اللذين تم اختيارهم سابقاً . فإذا كانت السجلات متطابقة في كلا الجدولين ، يتم مقارنة الحقول المشتركة فقط - أي الحقول الموجودة و المتشابهة بالإسم في الجدولين (باستثناء الحقل الأساسي) لتحديد التغييرات . فإذا كانت السجلات مفقودة في أحد الجدولين ( أي تم الحذف أو الإضافة في أي من الجدولين ) ، يتم تحديد نوع التغيير كـ ( عملية حذف ) أو ( عملية إضافة ). إدخال النتائج وإضافتها للجدول DifferencesTable يتم إضافة البيانات الناتجة عن التغييرات ( مثل القيمة القديمة والجديدة ) في جدول DifferencesTable ، مع تسجيل نوع التغيير ( إضافة، حذف، أو تعديل ) . إنشاء استعلام PIVOT أو ما يعرف بالإستعلام Crosstab بعد الانتهاء من المقارنة في الخطوة السابقة ، يتم إنشاء استعلام من نوع Pivot أو Crosstab ( استعلام جدولي كما يسمى في آكسس الواجهة العربية ) ؛ وهو يستخدم لتحويل البيانات من شكل الصفوف إلى شكل الأعمدة ( إن صح التعبير ) ، مما يجعل هذه البيانات أكثر تنظيماً وأسهل في التحليل و القراءةً . والهدف منه هو عرض التغييرات بطريقة منظمة باستخدام الحقول المشتركة بين الجدولين . فتح الاستعلام في نهاية الكود ، يتم فتح الاستعلام الذي يعرض الفروقات والتغيرات بين الجدولين بشكل عادي . ⭐ وظائف أخرى يتم استدعائها لأنشاء الجدول DifferencesTable بعد التأكد من وجوده أو لا . وأخرى لإنشاء الإستعلام الذي يحتوي التغيرات التي تم تعقبها :- وظيفة التأكد من وجود الجدول أو لا :- Function TableExists(tableName As String) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef TableExists = False Set db = CurrentDb For Each tdf In db.TableDefs If tdf.Name = tableName Then TableExists = True Exit For End If Next tdf End Function في حال عدم وجود الجدول DifferencesTable ، سيتم استدعاء هذا الـ Sub لإنشائه مع الحقول التي سنحتاجها لعرض البيانات المختلفة في الجدولين :- Sub CreateDifferencesTable(db As DAO.Database) Dim tdf As DAO.TableDef Set tdf = db.CreateTableDef("DifferencesTable") tdf.Fields.Append tdf.CreateField("ID", dbLong) tdf.Fields.Append tdf.CreateField("ChangeType", dbText, 50) tdf.Fields.Append tdf.CreateField("FieldName", dbText, 50) tdf.Fields.Append tdf.CreateField("OldValue", dbMemo) tdf.Fields.Append tdf.CreateField("NewValue", dbMemo) db.TableDefs.Append tdf End Sub بعد تتبع التغيرات والفروقات ، سيتم انشاء استعلام باسم Foksh ، لعرض التغيرات التي تم التعرف عليها :- Sub CreatePivotQuery(table1 As String, table2 As String) Dim queryDef As DAO.queryDef Dim sql As String sql = "TRANSFORM First('" & table1 & " ' & [OldValue] & ' - ' & '" & table2 & " ' & [newvalue]) AS dd " & _ "SELECT DifferencesTable.ID " & _ "FROM DifferencesTable " & _ "GROUP BY DifferencesTable.ID " & _ "PIVOT DifferencesTable.FieldName;" On Error Resume Next CurrentDb.QueryDefs.Delete "Foksh" On Error GoTo 0 Set queryDef = CurrentDb.CreateQueryDef("Foksh", sql) Set queryDef = Nothing End Sub وأخيراً وليس آخراً :- UnMatched.accdb وهذه صورة للبرنامج :-

وعليكم السلام ورحمة الله وبركانه لم نوضح لنا مكان كتابة النتائج النهائية وكيف ترغب شكلها النهائي في الملف العمود c كلمة نطايق نعنى ان لها مثيل في العمودين d-e وفي العمود f كلمة نطايق نعنى ان لها مثيل في العمودين A - B الكود Sub CompareTablesInOneSheet() Dim ws As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long Dim j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row lastRow2 = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row ws.Range("C2:C" & lastRow1).ClearContents ws.Range("F2:F" & lastRow2).ClearContents For i = 2 To lastRow1 For j = 2 To lastRow2 If ws.Cells(i, 1).Value = ws.Cells(j, 4).Value And ws.Cells(i, 2).Value = ws.Cells(j, 5).Value Then ws.Cells(i, 3).Value = "متطابق" ws.Cells(j, 6).Value = "متطابق" Exit For End If Next j If ws.Cells(i, 3).Value <> "متطابق" Then ws.Cells(i, 3).Value = "غير متطابق" End If Next i For j = 2 To lastRow2 If ws.Cells(j, 6).Value <> "متطابق" Then ws.Cells(j, 6).Value = "غير متطابق" End If Next j MsgBox "تم مقارنة البيانات بنجاح!" End Sub الملف Test.xlsb

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم الكود التالي لعله المطلوب Sub ColorCellsAboveYellow() Dim ws As Worksheet Dim cell As Range Dim targetColor As Long Dim i As Integer Set ws = ThisWorkbook.Sheets("Sheet1") targetColor = RGB(255, 255, 0) For Each cell In ws.UsedRange If cell.Interior.Color = targetColor Then For i = 1 To 2 If cell.Row - i > 0 Then ws.Cells(cell.Row - i, cell.Column).Interior.Color = targetColor End If Next i End If Next cell End Sub Book1.xlsm

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

مشاركة مع اخي محمد يمكن الاستعانة بوسيط لإخراج الصور على النحو التالي : افتح البرنامج على عرض التصميم في جزء التنقل : - حدد النموذج الذي يحتوي على صورة خلفية أو تنسيق تلقائي تريده - انقر بزر الماوس الأيمن على النموذج في جزء التنقل وحدد تصدير >> XML في الصفحة الأولى من المعالج ، حدد مكان الحفظ انقر التالي او موافق سيظهر لك مربع حوار صغير به ثلاثة مربعات اختيار قم باختيار الخيار الأول (البيانات) والخيار الثالث (العرض التقديمي) ثم اضغط موافق انقر فوق الزر "إغلاق" في الصفحة الأخيرة من المعالج بعد اكتمال عملية التصدير اذهب الى مكان الحفظ ستجد جميع صورك في مجلد Images

السلام عليكم ورحمه الله وبركاته دا جزاء من مشروع شغال عليه يلمس هذا الموضوع ساقوم بإرفاق ملف الوظائف التي يقوم بها 1- تعطيل / تفعيل مفتاح الشفت 2-ربط ديناميكي / ربط يدوي لــ الواجهات الاماميه (النماذج) مع الواجهات الخلفيه (الجداول) 3-اخفاء جميع كائنات الاكسس الواجهات الاماميه (النماذج) مع عدم القدره ع استيرادها من ملف اكسس اخر 4-اخفاء جميع كائنات الاكسس من الواجهات الخلفيه (الجداول) مع عدم القدره ع استيرادها من ملف اكسس اخر يرجي الافاده بعد التجربه خاص اوفسينا.rar

السلام علبكم 🙂 بسبب اختلاف تنسيقات ملفات الاكسل (او CSV) ، وخصوصا تلك التي من مواقع وزارة التعليم في المملكة العربية السعودية ، كنا نضطر ان نتعامل بالكود مع كل تنسيق بطريقة تختلف عن الملف الآخر ، مما يجعل الحل لا يتناسب مع التنسيقات الملفات الاخرى ، وهذا الكود ليس بالسهل تعديله. ولكن ، تقريبا جميع مستخدمي الاكسس يعرفون التعامل مع الاستعلام ، لهذا السبب دعونا نتعامل مع بيانات الاكسل في استعلام ، استعلام مسقط 🙂 هذه واجهة النموذج الذي يتم كل شيء عن طريقه: 1. لتصفح الملفات ، واختيار ملف الاكسل (xls, xlsx, xlsm, csv) ، وسيظهر اسم الملف الذي تم اختيارة في الحقل رقم 2 ، 3. ستظهر قائمة بأسماء الاوراق (Sheets) الموجودة في الملف ، ويجب اختيار الورقة المطلوبة ، 4. هذا نموذج جدولي ، و ستظهر بيانات ورقة الاكسل هنا ، ويمكننا التعامل مع فرز وتصفية البيانات هنا ، وبعدة طرق ، 5. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 6. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبدون أسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 7. يجب النقر هنا حتى نرى نتائج الفرز والتصفية كجزء من الاستعلام في الحقول 8 و 9 ، 8. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 9. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 10. يمكنك عمل استعلام جاهز (للورقة بدون فرز وتصفية) او جدول ، سواء في قاعدة البيانات هذه ، او اختيار قاعدة بيانات خارجية (يجب ان تكون مغلقة حتى تستطيع تصدير استعلام او جدول لها) ، وسيكون اسم الاستعلام نفس اسم الورقة ، مثلا اسم الورقة ABC ، فيصبح اسم الاستعلام: qry_ABC ، او يكون جدول بإسم tbl_ABC حسب اختيارك من الرقم 11 ، او حتى الحاق بيانات الاستعلام الى جدول موجود سابقا (طبعا يجب مراعاة ان يكون الجدول بنفس حقول الورقة) ، 12. لنسخ الاستعلام الى ذاكرة الكمبيوتر ، بحيث يمكنك استعمال لصق ctrl+v لكائن الاستعلام (انظ الفيديو التوضيحي) ، 13. عادة لا نغير اي شيء هنا. طريقة العمل: . نرى من اعلاه: 1. انه تم عمل استعلام ياسم qry_Sheet1 في قاعدة البيانات الخارجة Testing.accdb ، 2. كذلك نسخنا استعلام التصفة الى ذاكرة الكمبيوتر (تابع في الفيديو التالي) . ممكن خلط عمل الفرز و التصفية بعدة طرق ، منها كما في الفيديو اعلاه ، و الصور التاليه . . لنفتح قاعدة البيانات الخارجية ونرى ما فيها ، هنا نحن نتعامل مع استعلام اكسس عادي ، فيمكننا حذف الحقول التي لا نريدها ، او نخفي اخرى ، او .... . عند فتح قاعدة البيانات الخارجية ، وحصلت على رسالة الخطأ هذه ، فهذا معناه ان برنامج "استعلام مسقط" لايزال مفتوح ، وملف الاكسل مفتوح به ، لذا يجب اغلاق برنامج "استعلام مسقط" قبل استعمال ملف الاكسل : . البرنامج يتعامل مع ملف واحد فقط ، ويعمل له استعلام ، واذا اردنا ان نتعامل مع اكثر من ورقة اكسل ، فيمكننا عمل مجموعة من استعلامات ، ثم نعمل امر لتنفيذها واحدة تلو الاخرى ، وبما انه عندنا استعلام ، فيمكننا تحويله الى جميع انواع الاستعلامات ، سواء استعلام الحاق ، او استعلام اضافة ، او استعلام لعمل جدول. هناك عدة ميزات في استعمال هذه الطريقة عن ربط الاكسل كجدول : 1. اسرع بكثير ، 2. عند استيراد كائنات قاعدة البيانات الى قاعدة اخرى ، فالاكسس يتوقف كثيرا عند الجداول الاكسل المرتبطة ، بينما لا يأخذ اي وقت لهذا الاستعلام 3. اختار الحقول اللي تريدها فقط ، جعفر Muscat_Query.zip

السلام عليكم بعد اذن استاذنا الفاضل محمد هشام يالنسبة لسؤالك اضغط على Ctrl + Shift + Enter اطلعت على ملفك وما قام به الاستاذ محمد هشام كاقي ووافي ولكن التعامل مع معادلات الصفيف تحتاج الى من ينتبه بحذر عند استخذام الملف لان ضباع الاقواس معناها نتائج خاطئة ارفق لك ملفا بواسطة كود يعمل تلقائيا عند الاختيار من القائمة الى جانب يقوم بتحديث القائمة اذا اضفت لها بيانا جديدا او اكثر DC.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub CreateBackup() Dim wb As Workbook Dim folderPath As String Dim fileName As String Dim fileExtension As String Dim backupName As String Dim backupNumber As Integer Dim fso As Object Dim file As Object Set wb = ThisWorkbook folderPath = wb.Path & "\" fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1) fileExtension = Mid(wb.Name, InStrRev(wb.Name, ".")) Set fso = CreateObject("Scripting.FileSystemObject") backupNumber = 0 For Each file In fso.GetFolder(folderPath).Files If InStr(file.Name, fileName) = 1 And InStr(file.Name, fileExtension) > 0 Then Dim currentNumber As Integer On Error Resume Next currentNumber = CInt(Mid(file.Name, Len(fileName) + 1, InStrRev(file.Name, fileExtension) - Len(fileName) - 1)) On Error GoTo 0 If currentNumber > backupNumber Then backupNumber = currentNumber End If End If Next file backupName = folderPath & fileName & (backupNumber + 1) & fileExtension wb.SaveCopyAs backupName MsgBox "تم إنشاء نسخة احتياطية باسم: " & vbCrLf & backupName, vbInformation, "نسخة احتياطية" End Sub الملف Ehab.xlsb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

DC.xlsx

السلام عليكم بعد اذن استالذنا أبومروان حل بواسطة المصقوفات الكود Sub ذكرين_انثيين() Dim ws As Worksheet Dim lastRow As Long Dim dataArray As Variant Dim males() As Variant Dim females() As Variant Dim resultArray() As Variant Dim maleCount As Long, femaleCount As Long Dim rowIndex As Long, i As Long, j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row dataArray = ws.Range("A2:F" & lastRow).Value ReDim males(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) ReDim females(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) maleCount = 0 femaleCount = 0 For i = 1 To UBound(dataArray, 1) If dataArray(i, 6) = "ذكر" Then maleCount = maleCount + 1 For j = 1 To UBound(dataArray, 2) males(maleCount, j) = dataArray(i, j) Next j ElseIf dataArray(i, 6) = "انثى" Then femaleCount = femaleCount + 1 For j = 1 To UBound(dataArray, 2) females(femaleCount, j) = dataArray(i, j) Next j End If Next i ReDim resultArray(1 To maleCount + femaleCount, 1 To UBound(dataArray, 2)) rowIndex = 1 i = 1 j = 1 Do While i <= maleCount Or j <= femaleCount For k = 1 To 2 If i <= maleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = males(i, col) Next col rowIndex = rowIndex + 1 i = i + 1 End If Next k For k = 1 To 2 If j <= femaleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = females(j, col) Next col rowIndex = rowIndex + 1 j = j + 1 End If Next k Loop For i = 1 To UBound(resultArray, 1) resultArray(i, 1) = i ' الترقيم يبدأ من 1 Next i ws.Range("A2:F" & lastRow).ClearContents ws.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray MsgBox "تم الترتيب بنجاح !", vbInformation End Sub الملف فرز حسب الجنس بشروط.xlsb

السلام عليكم ورحمة الله وبركاته في هذا الإصدار يوجد ثلاث تطبيقات ( الملف بالمرفقات ) - awsReg_Colorize_VBE لتلوين محرر الأكواد - awsReg_HyperLink_Warning لتفعيل وتعطيل [ application.FollowHyperlink warning ] تم شرح وإضافة الأكواد بالمشاركة التالية بالموضوع الأول الرابط من هنا - awsReg_User_Trusted_Helper_MOD للتحكم بالمواقع الموثوقة Trusted Locations التطبيق الأول : تلوين محرر الأكواد يوجد بعض الأدوات المجانية التي تتيح التعديل علي ألوان محرر الأكواد وتعتمد فكرتها علي التعديل في ملف الـ VBA{Ver}.dll مثال : https://github.com/gallaux/VBEThemeColorEditor ولكن يمكن تحقق نفس النتيجة يدوي او من خلال إضافة قيم للريجيستري يدوي : عن طريق الأكواد إضافة القيم التالية للريجيستري في المسار (HKEY_CURRENT_USER\Software\Microsoft\VBA\7.1\Common) 7.1 هو رقم الاصدار وقد يختلف وتم إضافة المسارات المتوقعة بالاكواد CodeForeColors | CodeBackColors | FontFace | FontHeight | FontCharSet طريقة الإستخدام :call setUpVbeColors(awsDark3) ملحوظة : عند اختيار الخط يفضل اختار ما يدعم اللغة العربية إذا كنت تريد إضافة تعليقات باللغة العربية كما يجب التاكد من الأحجام المتاحة فبعض الخطوط تتيح أحجام محددة مثال بانتظار مشاركة إبداعتكم التطبيق الثالث : إضافة مسار البرامج الخاصة بك في المواقع الموثوقة Trusted Locations لماذا يفضل إضافة المسار الخاص ببرنامجك إلي المواقع الموثوقة ؟ 1- الحد من ظهور التحذيرات أثناء عمل البرنامج وعند كل تشغيل 2- والأهم هي سرعة عمل الأكود فوفق دراسة قام بها بعض المبرمجين فإن الأكود تعمل بشكل أسعر يصل إلي 23× رابط المصدر من هنا اقتباس من المصدر : هل يوجد مكان واحد للإضافة ؟ لا يوجد أكثر من مكان للضافة ولكل مكان ميزاته وعيوبة مثال : فالمسار الخاص بإضافة المواقع الموثوقة لكل برنامج من برامج الاوفيس هو Software\Microsoft\Office\16.0\Access\Security\Trusted Locations ويتغير اسم البرنامج ورقم الإصدار وفق النسخة والبرنامج المستهدف فإذا كان الجذر (ROOT ) هو [ HKEY_CURRENT_USER ] فمن يتأثر بهذه المواقع هو اليوزر الحالي فقط ولكن إن كان [ HKEY_LOCAL_MACHINE] فيتأثر جميع المستخدمين كما ان هناك ترتيب فالموقع داخل HKEY_CURRENT_USER له الأفضلية علي HKEY_CURRENT_USER الموقع الموثوق عبارة عن مفتاح وهو اسم الموقع ويوجد بداخل قيم ويوجد تحت المفتاح الرئيس [Trusted Locations] قيم مثال [USER Trusted Locations Values] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations --------------------------------------------- [Value Name ] : AllLocationsDisabled [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All Trusted Locations are Allowed --------------------------------------------- [Value Name ] : AllowNetworkLocations [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All NetWork Locations are Disabled --------------------------------------------- [Locations] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\awsTLocation --------------------------------------------- [Location Name ] : awsTLocation [Location Number] : 02 [Location Values] : [Value Name ] : Path [Value Data ] : D:\AWSTRUSTLOCATION3\ [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Description [Value Data ] : This Location Has Been Trusted By : AWS REG [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Date [Value Data ] : 17/11/2024/ 10:41:00 AM [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : AllowSubfolders [Value Data ] : True [Value Type ] : REG_DWORD [Value Integer] : 1 [Note ] : All Sub Folders are Allowed ----------------------------------- --------------------------------------------- فإذا تم تفعيل القيمة [AllLocationsDisabled] تحت المفتاح [Trusted Locations] فهذا يعني تعطيل جميع المسارات الموثوقة تحذير هام: أنصح بعدم وضع المسارات شائعة الاستخدم كسطح المكتب والتنزيلات حتي لا نضعف حماية النظام ملحوظة: أكبر عدد مسموح به للإضافة هو 20 لكل برنامج أوفيس الأمثلة موجودة في مديول : awsReg_Trusted_Locations كما يوجد شرح أيضاً في راس المديول : awsReg_User_Trusted_Helper_MOD تم إضافة تعديل علي الكلاس مديول بإضافة دالة جديدة : allValuesKeysDictColl ------------------------------------------------------------------------------------------- أود الإشارة إلي هذه المقاطع داخل الأكواد لأهميتها 1- داخل الكود loadUserTrusted في هذا الجزء يتم إضافة المسارات الموجودة إلي قاموس ليتم التحقق منها لاحقاً وعلية قد يكون هناك مسار مكرر داخل مفاتيح باسماء مختلفة ولذلك أقوم بحذف الموقع الموثق صاحب المسار المكرر هكذا عالجت الأمر وفق تصوري 2- داخل الكود setUserAppTrustLocation تم تعليق هذا الجزء من الكود لعدم إحتياجي له ويمكنك تفعيله إذا كنت ترد ظهور رسالة في حال تم إيجاد اسم الموقع فإذا اجبت بنعم سيتم تغير المسار داخل الموقع الموجود وإذا أجبت بلا سيتم إضافة _1 لإسم الموقع وإضافة موقع جديد ------------------------------------------------------------------------------------------- يسعدني الإجابة علي استفسارتكم الأكواد متاح للجميع للتعديل والإضافات بالتوفيق winRegApi_OV2.zip

إليك الكود بعد تعديله Public Sub FilterAndCopy() Const tmpCol As String = "BC" Dim OnRng As Range, i As Long, n As Long, r As Long Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Set WS = Sheets("اجمالي4") Set Sh1 = Sheets("بنون ناجحون") Set Sh2 = Sheets("بنات ناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With n = 7: r = 7 For i = 1 To OnRng.Rows.Count + 1 If InStr(1, WS.Cells(i, tmpCol).Value, "ناجح", vbTextCompare) > 0 Then If WS.Cells(i, 9).Value = "ذكر" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n) n = n + 1 ElseIf WS.Cells(i, 9).Value = "انثى" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r) r = r + 1 End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

السلام عليكم حيث ان الأخ محمد من الأصدقاء القدامى .. وقد راسلني .. فهذه المشاركة قد تكون هي الأولى لي في منتدى جيراننا الأكارم مشاركة مع اخي ابي مروان وبعد اذنه يلزم تحديث الخلايا لديك لإزالة حرف الهاء قبل تشغيل الدالة يمكنك نقل الدالة لمحرر الورقة التي تريد تطبيق الكود عليها Sub Utest() Dim urg As Range Set urg = Range("J2:L10") 'غير حسب النطاق لديك Dim UCell As Range For Each UCell In urg UCell.NumberFormat = "@" If UCell.Value = "" Then UCell.Value = "" UCell.Value = Format(UCell.Value, "YYYY/MM/DD") Next End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إختيار ما يناسبك Sub CopyRowsmaktab() Dim LR As Long, I As Long, X As Long LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents For I = 6 To LR If Sheets("Main").Cells(I, "B").Value = "دريم" Then Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value X = X + 1 End If Next I Application.ScreenUpdating = True End Sub او Sub CopyRowsToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim WSRng As Range, destRng As Range, Criteria As String Set WS = Sheets("Main") Set dest = Sheets("دريم") Criteria = "دريم" LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = Criteria Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub او Sub CopiesToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim Ky As Boolean, WSRng As Range, destRng As Range Set WS = Sheets("Main") Set dest = Sheets("دريم") LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Ky = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Ky = True Exit For End If Next n If Not Ky Then MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim srcWS As Worksheet, début As Long, Fin As Long Dim a As Variant, b As Variant, i As Long Set srcWS = Me a = srcWS.[B3].Value b = srcWS.[C3].Value If Not Intersect(Target, srcWS.Range("B3:C3")) Is Nothing Then If a = "" Or b = "" Then Exit Sub If IsNumeric(a) And IsNumeric(b) Then début = a Fin = b If début <= Fin Then srcWS.Range("F7:F" & srcWS.Rows.Count).ClearContents For i = début To Fin srcWS.Cells(6 + i - début + 1, "F").Value = i Next i Else MsgBox _ " بداية الترقيم يجب أن تكون أصغر أو تساوي نهاية الترقيم", vbExclamation, "خطأ في الإدخال" End If End If End If End Sub بالمعادلات =IF(ROW(F7)-ROW($F$7)+$B$3<=$C$3, ROW(F7)-ROW($F$7)+$B$3, "") ترقيم.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub DistributeStudents() Dim ws As Worksheet Dim lastRow As Long Dim dataRange As Variant Dim outputRange As Variant Dim rowNum As Long, colNum As Long Dim colStart As Integer, colEnd As Integer Dim totalStudents As Long, committees As Long Dim studentsPerCommittee As Long, extraStudents As Long Dim failedRows As String Const MaxStudentsPerCommittee As Long = 29 Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, 9).End(xlUp).row colStart = 11 colEnd = 30 ' Clear the output range ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).ClearContents ws.Range("I2:I" & lastRow).Interior.Color = xlNone ' إزالة أي ألوان سابقة dataRange = ws.Range("I2:J" & lastRow).Value ReDim outputRange(1 To UBound(dataRange, 1), colStart To colEnd) failedRows = "" For rowNum = 1 To UBound(dataRange, 1) totalStudents = dataRange(rowNum, 1) committees = dataRange(rowNum, 2) If committees > (colEnd - colStart + 1) Then MsgBox "عدد اللجان في الصف " & rowNum + 1 & " يتجاوز الحد الأقصى للأعمدة المتاحة!", vbExclamation Exit Sub End If If totalStudents = 0 Or committees = 0 Then For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum Else If totalStudents > committees * MaxStudentsPerCommittee Then ws.Cells(rowNum + 1, 9).Interior.Color = RGB(255, 0, 0) For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum failedRows = failedRows & (rowNum + 1) & ", " Else studentsPerCommittee = totalStudents \ committees extraStudents = totalStudents Mod committees For colNum = colStart To colStart + committees - 1 If extraStudents > 0 Then outputRange(rowNum, colNum) = studentsPerCommittee + 1 extraStudents = extraStudents - 1 Else outputRange(rowNum, colNum) = studentsPerCommittee End If Next colNum For colNum = colStart + committees To colEnd outputRange(rowNum, colNum) = "" Next colNum End If End If Next rowNum ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).Value = outputRange If failedRows <> "" Then failedRows = Left(failedRows, Len(failedRows) - 2) ' إزالة الفاصلة الأخيرة MsgBox "تم توزيع الطلاب على اللجان بنجاح! ولكن لم يتم توزيع الطلاب في الصفوف التالية بسبب تجاوز الحد الأقصى لعدد الطلبة على عدداللجان: " & vbCrLf & failedRows, vbExclamation Else MsgBox "تم توزيع الطلاب على اللجان بنجاح!", vbInformation End If End Sub الملف التوزيع.xlsb

وعليكم السلام ورحمة الله وبركاته الكود يعمل تلقائيا عند الانتهاء من الكتابة في خلية والخروج منها New Microsoft Excel Worksheet (2).xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ممكن توضح لنا ما المانع من إظافة عمود التسلسل يدويا وإعادة تعديل الكود بما يتناسب مع شكل البيانات ؟ اذا كان هذا يناسبك إليك الكود المعدل Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range, response As VbMsgBoxResult Set WS = Sheets("ورقة1") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row response = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") If response = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If End If Next i If Not OnRng Is Nothing Then OnRng.Delete MsgBox OnRng.Count & " تم حذف الصفوف بنجاح", vbInformation, "عملية الحذف" Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" Exit Sub End If With WS.Range("A1:E50").Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i With WS.PageSetup .TopMargin = .BottomMargin = .LeftMargin = .RightMargin = Application.InchesToPoints(0.5) End With WS.[C1].Value = Date - 1: WS.[C1].NumberFormat = "dd/mm/yyyy" WS.[B1].Value = Format(Date - 1, "dddd") Application.ScreenUpdating = True End Sub مثال1.xlsm

السلام عليكم و رحمة الله اليك الملف ملف1.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Public Property Get WS() As Worksheet Set WS = Sheets("PTT") End Property Public Property Get dest() As Worksheet Set dest = Sheets("Round 5") End Property Private Sub CommandButton1_Click() Dim r As Long, s As Long, t As Long, tmp As Long, ID As String, n As Boolean If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then MsgBox "لا يوجد أي إيصالات للطباعة على قاعدة البيانات ", vbExclamation Exit Sub End If On Error Resume Next For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt WS.[d4] = ID WS.[U2] = ID Err.Clear WS.PrintOut If Err.Number <> 0 Then MsgBox "تم إلغاء طباعة الإيصالات", vbExclamation Exit Sub End If Cnt: Next r WS.[aa1] = s WS.[aa2] = t Unload Me End Sub '===================================== Private Sub CommandButton2_Click() Dim r As Long, tmp As Long, s As Long, t As Long, FolderName As String Dim filePath As String, ID As String, n As Boolean, pdfFolder As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات ", vbExclamation: Exit Sub FolderName = "الإيصالات" pdfFolder = ThisWorkbook.Path & "\" & FolderName If Dir(pdfFolder, vbDirectory) = "" Then On Error Resume Next MkDir pdfFolder If Err.Number <> 0 Then: Exit Sub On Error GoTo 0 End If For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt End If WS.[d4] = ID: WS.[U2] = ID filePath = pdfFolder & "\invoice_" & ID & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me End Sub PTT 2024 v2.xlsm

ولا يهمك أخي @محمد العراقى سنكون سعداء دائما بحصولك على النتائج المطلوبة يكفي تعديل هدا الجزء من الكود For j = LBound(DaysArr) To UBound(DaysArr) For i = 0 To 7 ' الحصص dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value ' المواد If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value End If Next i cnt = cnt + 8 Irow = Irow + 2 Next j اجر-V2.xls

جرب هدا Dim OnRng(), tbl, Irow, ColVisu(), Dates(), Choix() Private Sub UserForm_Initialize() tbl = "Table2" OnRng = Range(tbl).value For i = 1 To UBound(OnRng): OnRng(i, 2) = CDate(OnRng(i, 2)): Next i Irow = Range(tbl).Columns.Count ColVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) ListBox1.ColumnCount = 12 Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 3)) = "" Next i Choix = d.keys '================' رقم السيارة ============== Tri Choix, LBound(Choix), UBound(Choix) Dim iTemp As Variant For i = LBound(Choix) To (UBound(Choix) - LBound(Choix)) \ 2 iTemp = Choix(i) Choix(i) = Choix(UBound(Choix) - i) Choix(UBound(Choix) - i) = iTemp Next i Me.ComboBox1.List = Choix '================' اسم السائق ======================== Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 4)) = "" Next i Choix = d.keys Tri Choix, LBound(Choix), UBound(Choix) Me.ComboBox4.List = Choix Set d = CreateObject("scripting.dictionary") colDate = 2 For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, colDate)) = "" Next i Dates = d.keys Tri Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) Filtre End Sub Sub Filtre() Dim tbl() clé = Me.ComboBox1: If clé = "" Then clé = "*" cléLieu = Me.ComboBox4: If cléLieu = "" Then cléLieu = "*" début = CDate(Me.ComboBox2) fin = CDate(Me.ComboBox3) colDate = 2 n = 0 For i = LBound(OnRng) To UBound(OnRng) If OnRng(i, colDate) >= début And OnRng(i, colDate) <= fin And OnRng(i, 3) Like clé And OnRng(i, 4) Like cléLieu Then n = n + 1: ReDim Preserve tbl(1 To Irow, 1 To n) c = 0 For Each K In ColVisu c = c + 1: tbl(c, n) = OnRng(i, K) Next K End If Next i If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear MsgBox "لم يتم العثور على بيانات مطابقة", vbInformation, "نتائج التصفية" End If End Sub ListBox1.ColumnCount = 12-V2.xlsm

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

السلام عليكم ورحمة الله وبركاته الأخوة الكرام بارك الله فيكم تجدون بالملف المرفق قاعدة بيانات بها - [ awsReg ] وهو Class Module للتحكم بالريجيستري [ Windows Registry ] - [ awsReg_Test_Module ] وهو مديول به نماذج لتوضيح كيفية للإستخدام حاولت قدر المستطاع تغطية جميع الإستخدامات - [ باقي المديولز ] هي ضرورية للعمل نبذة مختصرة - مصدر الكود من هنا : https://learn.microsoft.com/en-us/previous-versions/office/developer/office2000/aa155731(v=office.10)?redirectedfrom=MSDN&ref=nolongerset.com - من قام بتعديل التعريفات لتناسب 64x من هنا : https://nolongerset.com/regop-class-for-64-bit-vba/ - قمت بفضل الله ونعمتة ( الحمد كله لله أوله وأخره) 1- دمج وتجهيز الكود بالكامل 😁 2- تعديل نظام عرض الرسائل والأخصاء بالكامل يدعم اللغة ( العربية - الإنجليزية ) 3- تعديل وظيفة allValue لتعود بي 3D Array القيمة والبيانات ونوعها 4- تعديل وظيفة value لتعود بي 2D array البيانات ونوعها 5- إضافة وظيفة allKeysDict - [Get Property] لتعود بالمفاتيح الفرعية داخل قاموس 6- إضافة وظيفة allValuesDict - [Get Property] لتعود بالقيم الموجودة في مفتاح داخل قاموس 7- إضافة وظيفة IsKeyExists لتعود بنعم إذا كان المفتاح موجود (تم إضافة الـ Api الخاص بها) 8- إضافة وظيفة IsValueExists لتعود بنعم إذا كانت القيمة موجودة 9- التعديل علي بعض الأكواد وإضافة وظائف أخري (قد نأتي لذكرها لاحقاً "إن شاء الله" شرح لمثال واحد [ كتابة قيم داخل الريجيستري ] باقي الأمثلة موجودة بالملف Public Sub Test_awsReg_WriteValues() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = "Software\awsApp" ' awsApp Doesn't Exist Yet Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath ' REG_SZ Writing a string value .value("MyString") = "Hello, World!" .value("Date") = Format(Now, "yyyy-mm-dd hh:nn:ss") .value("awsPath") = "%USERPROFILE%\Documents" ' REG_DWORD Writing a numeric value [0 For False] [1 For True] .value("isValid") = CInt(1) .value("myNumber") = 2341 .Options = StoreNumbersAsStrings 'this to store numbers as String .value("strNumer") = 5246 ' REG_MULTI_SZ Writing an array (multi-string value) Dim myArray(2) As String myArray(0) = "Value1" myArray(1) = "Value2" myArray(2) = "Value3" .value("MyArray") = myArray Debug.Print "Values written successfully" End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub النتيجة : الأخوة الكرام الكود متاح للجميع نسعد بتعديلاتكم ومشاركتكم وإستفساركم بالتوفيق winRegApi_V1_FN.zip

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim n As Object: Set n = CreateObject("Scripting.Dictionary") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kay As String, j As Variant If Not Intersect(Target, WS.Range("A4:B" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS ' مسح النتائج السابقة .Range("I3:J" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 ' تحديد صف وضع النتائج ' بداية من الصف 4 For i = 4 To lastRow tmp = .Cells(i, 1).value ' الحصول على القيمة من عمود A kay = .Cells(i, 2).value ' الحصول على القيمة من عمود B ' التأكد من أن القيم ليست فارغة If tmp <> "" And kay <> "" Then If n.Exists(tmp) Then n(tmp) = n(tmp) & ", " & kay Else n.Add tmp, kay End If End If Next i For Each j In n.Keys .Cells(ling, 9).value = j ' القيم الفريدة في عمود I .Cells(ling, 10).value = n(j) ' القيم المرتبطة في عمود J ling = ling + 1 Next j ' تعديل عرض العمود ليتناسب مع المحتوى .Columns("J").AutoFit End With Application.ScreenUpdating = True End If End Sub TEST CODE.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

تفضل وجدت الخلل في ترتيب شروط الدالة عدلتها وايضا عدلت على دالة النتيجة النهائية مثلها بالضبط ايضا لاحظ اني عملت متغير عام يأخذ قيمته عند حدث بعد التحديث لحقل الصف في نموذج التقارير .. وقيمته هي معرف الصف البحث وتعديل درجات3.rar

أخي الكريم @Foksh الأخوة الكرام صبحكم الله بالخير 1- إلغاء وتفعيل الحماية الخاصة بـ application.FollowHyperlink 2- إضافة مسار البرنامج لـالــ Access\Security\Trusted Locations 3- يعتبر الرجستري وسيط بين الوجهات المتعددة مثال 1 : أعمل بكود لضبط وتحجيم أبعاد الاكسيس والتعامل مع أكثر من شاشة بحيث يسمح للمستخدم بعرض البرنامج علي الشاشة 1 او 2 إن كان متصل بالجهاز أكثر من شاشة وإن كانت الابعاد مختلفة تختلف أبعاد البرنامج وهو يعتمد علي الجداول بشكل أساسي وإن كان هناك أكثر من واجهة تحتاج إلي تطبيق الامر علي كل واجهة ولكن الريجيستري يعتبر وسيط يسمح لك بتمرير القيم وإستدعائها وتعين قيم افتراضية مثال 2 : يمكن إستخدامة في حماية البرنامج الخاص بك فإضافة قيم في الريجيستري تسمح لك بالتحقق من - متي أول مرة تم إستخدام البرنامج (للمدة التجريبة) - إضافة مفاتيح خاصة بكل جهاز - الأفكار كثيرة أظن كدا فكرة الوساطة واضحة وأتمني أسمع أفكاركم 🧠 4- إستدعاء بعض المعلومات التي تحتاج إليها مثل - معرفة مسار النظام الافتراضي [ HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion ] - معرفة جميع الطابعات الموجودة [ HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Printers ] - معرفة الطابعة الإفتراضية [ HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows ] ثم [ Device ] 5 - تغير الإعدادات - تغير الطابعة الإفتراضية - عدم السماح للوندوز بتجاوز إختيار - فيما أذكر يمكن التحكم بالطابعة الإفتراضية من خلال الريجيستري كعمل بروفايل خاص بإعدادات خاصة أرجو لكم التوفيق والسداد والتعامل مع الريجيستري بحذر ويفضل دائماً أخذ نسخة احتياطية للأمان

وعليكم السلام ورحمة الله وبركاته.. ما يجب التحقق منه عدة نقاط ، أذكر منها :- 1. تحقق من لغة الـ Unicode في الويندوز . 2. تنسيقات الوقت والتاريخ في الويندوز . 3. نسخة الأوفيس وإصدارها . 4. بعد النقطة 3 اذا كان الملف مفتوح المصدر قم بضغط وإصلاح القاعدة على نفس الجهاز . 5. الأصل و قبل هذا كله ، التأكد من سلامة قاعدة البيانات والتنسيقات لهذه العناصر ( مربعات النص ) ومصادر بياناتها في الجداول . 💡 هذا من وجهة نظري والله أعلم.

وعليكم السلام ورحمة الله وبركاته ,, بدايةً قمت بتغيير بعض اسماء العناصر من العربية الى الانجليزية ، ولكنها ليست ذات صلة بالحل . اجعل هذا الاستعلام مصدر سجلات التقرير SELECT tbl_info_fonctionnaire.grade_poste_actuel, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=0 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<30,1,0)) AS عدد_الذكور_أقل_من_30, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=0 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<30,1,0)) AS عدد_الإناث_أقل_من_30, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=30 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=40,1,0)) AS عدد_الذكور_بين_30_و_40, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=30 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=40,1,0)) AS عدد_الإناث_بين_30_و_40, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=41 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=50,1,0)) AS عدد_الذكور_بين_41_و_50, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=41 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=50,1,0)) AS عدد_الإناث_بين_41_و_50, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=51 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=55,1,0)) AS عدد_الذكور_بين_51_و_55, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=51 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=55,1,0)) AS عدد_الإناث_بين_51_و_55, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=56 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=59,1,0)) AS عدد_الذكور_بين_56_و_59, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=56 And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())<=59,1,0)) AS عدد_الإناث_بين_56_و_59, Sum(IIf(tbl_info_fonctionnaire.sex="ذكر" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=60,1,0)) AS عدد_الذكور_أكبر_من_60, Sum(IIf(tbl_info_fonctionnaire.sex="أنثى" And DateDiff("yyyy",tbl_info_fonctionnaire.date_naissance,Date())>=60,1,0)) AS عدد_الإناث_أكبر_من_60, Count(IIf(tbl_info_fonctionnaire.sex="أنثى",1,Null)) AS عدد_الإناث_حسب_الدرجة, Count(*) AS المجموع_الكلي FROM tbl_info_fonctionnaire GROUP BY tbl_info_fonctionnaire.grade_poste_actuel; الملف بعد التعديل base_S - Copy.accdb اعتذر ، لم أر تعليق الأستاذ @ابو البشر ، ولكن له الأصل في حق الإجابة كنت في الصفحة ولم اقم بعمل تحديث لها قبل الرد أثناء كتابة الاستعلام والتجارب عليه

وعليكم السلام ورحمة الله تعالى وبركاته بما أنك تستخدم الأكواد على الملف أعتقد أنه بإمكانك ربط الكود بأي شكل وتقوم بوضعه فوق الصورة عادي نفس الفكرة المقترحة من الأخ @أبومروان بواسطة الأكواد مع إمكانية تحديد إسم الصورة والتعليق المرغوب إظهاره .يمكنك إظافة أي عدد من الأشكال وتعديل النطاقات بما يتناسب مع إحتياجاتك wor-v2.xlsm

Driver (1).accdb

السلام عليكم اتفضل وانصحك باستخدام الداله فى الموضوع التالى لاخى ومعلمى العزيز جعفر بالتوفيق رصيد_تراكمى_1.accdb

وعليكم السلام أخي غسان .. مع أن الملف بدون بيانات ولكن عبأته لك ببيانات عشوائية .. وطبقت عليه فكرة والدنا العزيز @ابوخليل 🙂 والدور على معلمنا الحبيب @Foksh ليطبق فكرته 😊👌 ghassan.accdb

بما أنك لم تجب عن سؤالي إليك طريقة أخرى ستقوم بإظافة عنصر جديد بإسم Line لإستخراج رقم صف المحدد عند الإختيار من عناصر الكومبوبوكس وإعتمادا عليه سنقوم بتعديل وحدف الصفوف Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm

ممكن تشرح لنا ماذا تريد حتى نفهم .... لا تقسط لنا المعلومات !!!!! اعطنا النموذج الاساسي لديك .... ثم ماذا تريد ان تعرض والافتراضات فيها ؟؟؟

وعليكم السلام ورحمة الله وبركاته المعادلة =SUMIFS(C:C; B:B; ">=" & DATE($E$4;1;1); B:B; "<=" & DATE($E$4;12;31)) الملف جمع القيم بناء على السنة.xlsx وفقكم الله

السلام عليكم ورحمة الله وبركاته عن طريق الكود ويمكن اضافة اي حرف احتمال يحدث فيه اختلاف شاهد المرفق بحث حتى لو فى اخلاتف بسيط1.xls وفقك الله

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

ليس الاستعلام فقط .... ايضا حول مربع التسمية الى مربع نص ايضا اجعل خاصية مربع النص .. اخفاء التكرار . نعم

انظر هذا الموضوع يفيدك .... استخدم خاصية البحث في المنتدى

وعليكم السلام 🙂 بإختصار ، الاكسس يعمل كل عمله على حاسبة المستخدم. الاستعلام يستورد البيانات المطلوبة من الجداول (سواء جداول محليه او على الشبكة او في السحاب) ، ويقوم بتحليلها محليا. لهذا السبب ، وحسب تصميم برنامجك (فهرست الحقول في الجداول ، وهي الحقول التي نستخدمها في الفرز او التصفية او ربطها بجدول آخر) ، 1. ممكن الاستعلام يستورد سجلات قليلة وبسرعة لحقل مفهرس (فالحقول المفهرسة لها مكان يشبه الجداول ، والتي ينظر فيها الاستعلام اولا) ، لأنه يعرف مكان هذه السجلات بحسب الحقل المفهرس ، 2. او اذا لم يكن هناك حقل مفرس ، يضطر الى استيراد الجدول كاملا لقراءته محليا ، ويعطيك نتائج الاستعلام ، وهذه الطريقة تأخذ وقت اطول. قواعد البيانات الاخرى مثل SQL Server ، والتي يجب ان تكون على سيرفر به مواصفات عالية ، تقوم بعمل كل شيء على السيرفر وتعطي النتيجة جاهزة لواجهة البرنامج والذي عادة يكون المتصفح (الواجهة) . اما اذا استعملت الاكسس كواجهة ، مع SQL Server كخلفية ، فيمكنك عمل الاثنين ، استعلامات في الواجهة (والتي ستكون بطيئة ، لأنها تستورد البيانات من السيرفر ، إلا اذا كان الاستعلام لبيانات قليلة او مفهرسة) ، او يمكنك عمل استعلامات في SQL Server (والتي تسمى Views او Stored Procedure) . كنت اعتقد كلامي كان بإختصار 😁 جعفر

سبحان الله الانسان حبيس أفكارة الفكرة مشيت بتسلسل معين وإلا احلها بالطريقة دي الحمد لله والشكر لله الحل ببساطة :- '/// Function: MsgLog2 '/// Logs a message with various options for display and handling '/// @param message - The message to be logged '/// @param level - (Optional) The log level (default: llInfo) '/// @param useDebug - (Optional) Whether to use debug output (default: False) '/// @param showMsgBox - (Optional) Whether to show a message box (default: False) '/// @param msgTitle - (Optional) The title of the message box (default: "") '/// @param arabicRTL - (Optional) Whether to use right-to-left layout for Arabic text (default: False) '/// @param buttons - (Optional) The buttons to display in the message box (default: mbOKOnly) '/// @param defaultButton - (Optional) The default button in the message box (default: db1First) '/// @param timeoutMs - (Optional) Timeout in milliseconds for the message box. Ex: SecToMs(5) or 5000 Public Function MsgLog2(ByVal message As String, _ Optional ByVal level As LogLevel = llInfo, _ Optional ByVal useDebug As Boolean = False, _ Optional ByVal showMsgBox As Boolean = False, _ Optional ByVal msgTitle As String = "", _ Optional ByVal arabicRTL As Boolean = False, _ Optional ByVal buttons As MsgBoxButtons = mbOKOnly, _ Optional ByVal defaultButton As defaultButton = db1First, _ Optional ByVal timeoutMs As Variant) As VbMsgBoxResult Dim msgBoxStyle As VbMsgBoxStyle Dim msgBoxTitle As String Dim fullMessage As String Dim actualTimeout As Long Dim mResult As VbMsgBoxResult Dim tResult As VbMsgBoxResult Dim mTitle As String MsgLog2 = vbOK ' Format the message fullMessage = FormatLogMessage(message, level) ' Set message box properties based on log level Select Case level Case llInfo msgBoxStyle = vbInformation If arabicRTL = False Then msgBoxTitle = "Information" Else msgBoxTitle = ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629) End If Case llWarning msgBoxStyle = vbExclamation If arabicRTL = False Then msgBoxTitle = "Warning" Else msgBoxTitle = ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631) End If Case llError msgBoxStyle = vbCritical If arabicRTL = False Then msgBoxTitle = "Error" Else msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) End If Case llCritical msgBoxStyle = vbCritical If arabicRTL = False Then msgBoxTitle = "Critical Error" Else msgBoxTitle = ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H62E) & ChrW(&H637) & ChrW(&H64A) & ChrW(&H631) End If Case llQuestion msgBoxStyle = vbQuestion If arabicRTL = False Then msgBoxTitle = "Question" Else msgBoxTitle = ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644) End If End Select If msgTitle = "" Then Else msgBoxTitle = msgTitle End If ' Combine style with buttons and default button If arabicRTL = False Then msgBoxStyle = msgBoxStyle + buttons + vbMsgBoxSetForeground + defaultButton Else msgBoxStyle = msgBoxStyle + vbMsgBoxRight + vbMsgBoxRtlReading + buttons + vbMsgBoxSetForeground + defaultButton End If ' Output to Debug if requested If useDebug Then ' Use This format upon your needs ' Debug.Print format(Now, "yyyy-mm-dd hh:nn:ss AM/PM") & " " & Replace(fullMessage, vbCrLf, vbCrLf & String(13, " ")) Debug.Print Replace(fullMessage, vbCrLf, vbCrLf & String(13, " ")) End If TempVars.Remove "tempLog" TempVars!tempLog = Replace(fullMessage, vbCrLf, vbCrLf & String(18, " ")) ' Show message box if requested If showMsgBox Then fullMessage = FormatMsgBox(fullMessage) If arabicRTL = False Then Else fullMessage = Replace(fullMessage, "INFO ", ChrW(&H645) & ChrW(&H639) & ChrW(&H644) & ChrW(&H648) & ChrW(&H645) & ChrW(&H629) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20)) fullMessage = Replace(fullMessage, "WARNING ", ChrW(&H62A) & ChrW(&H62D) & ChrW(&H630) & ChrW(&H64A) & ChrW(&H631) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20)) fullMessage = Replace(fullMessage, "ERROR ", ChrW(&H62E) & ChrW(&H637) & ChrW(&H623) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20)) fullMessage = Replace(fullMessage, "CRITICAL ", ChrW(&H647) & ChrW(&H627) & ChrW(&H645) & ChrW(&H20) & ChrW(&H62C) & ChrW(&H62F) & ChrW(&H627) & ChrW(&H64B) & ChrW(&H20) & ChrW(&H20)) fullMessage = Replace(fullMessage, "Question ", ChrW(&H633) & ChrW(&H624) & ChrW(&H627) & ChrW(&H644) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20) & ChrW(&H20)) End If If IsMissing(timeoutMs) Or VarType(timeoutMs) = vbString Then ' Use standard MsgBox if no timeout specified MsgLog2 = MsgBox(fullMessage, msgBoxStyle, msgBoxTitle) Else If IsNumeric(timeoutMs) Then actualTimeout = CLng(timeoutMs) Else actualTimeout = DEFAULT_TIMEOUT End If If actualTimeout < MIN_TIMEOUT Then actualTimeout = MIN_TIMEOUT If actualTimeout > MAX_TIMEOUT Then actualTimeout = MAX_TIMEOUT ' Use tempMsgBox with timeout If arabicRTL = False Then mTitle = " - " & Round(MsToSec(actualTimeout), 1) & " Sec Time-Out MSG" Else mTitle = " - " & _ ChrW(&H20) & ChrW(&H631) & ChrW(&H633) & ChrW(&H627) & ChrW(&H644) & ChrW(&H629) & ChrW(&H20) & ChrW(&H645) & ChrW(&H624) & ChrW(&H642) & ChrW(&H62A) & ChrW(&H629) & ChrW(&H20) & ChrW(&H644) & ChrW(&H645) & ChrW(&H62F) & ChrW(&H629) & ChrW(&H20) & _ Round(MsToSec(actualTimeout), 1) & _ ChrW(&H20) & ChrW(&H62B) & ChrW(&H648) & ChrW(&H627) & ChrW(&H646) & ChrW(&H64A) End If MsgLog2 = tempMsgBox(fullMessage, msgBoxStyle, msgBoxTitle & mTitle, actualTimeout) ' printUserChoice tResult End If End If End Function طريقة الإستخدام : Dim msgResponse As VbMsgBoxResult msgResponse = MsgLog2("نص السؤل ؟", _ llQuestion, _ False, _ True, _ "عنوان الرسالة", _ True, _ mbYesNo, _ db4Fourth, _ SecToMs(8)) If msgResponse = vbNo Then Else End If MsgLog_UrlChecker_v2.accdb

السلام عليكم ورحمة الله وبركاته الأخوة الكرام / أسعد الله أوقاتكم أخي الكريم @عمر ضاحى شكراً لك أخي الفاضل @Foksh تفضل أخي الكريم المثال المرفق مصدر وظائف التحقق من الموقع من هنا : 1- https://www.devhut.net/using-regex-to-validate-a-url/ 2- https://www.devhut.net/vba-validate-if-a-url-exists/ تم التعديل فقط لتناسب الفكرة تم إضافة الكود التالي للوظيفة الرئيسية MsgLog وهو ليس ضروري ويمكن استبدالة بمعرف ثابت (ليعمل داخل الاكسل) TempVars.Remove "tempLog" TempVars!tempLog = Replace(fullMessage, vbCrLf, vbCrLf & String(18, " ")) أمثلة للأختبار ? MSXML_URLExist("https://httpstat.us/408") ? MSXML_URLExist("https://www.yahoo.com/" & String(50000, "a")) ? MSXML_URLExist("https://www.google.com/" & String(50000, "a")) ? MSXML_URLExist("https://httpstat.us/504") ? MSXML_URLExist("https://httpstat.us/200?sleep=10000") ? MSXML_URLExist("https://www.google.com") ? MSXML_URLExist("https://httpstat.us/503") ? MSXML_URLExist("https://httpstat.us/414") إذا كنت تختبر الأمر في وضع المطور علي شاشة تحرير الأكود فعليك تعديل الخيارت التالية إلي Public Const Debugging_Mode_ON As Boolean = True Public Const MsgBox_Mode_ON As Boolean = False أرجو لكم التوفيق والسداد MsgLog_UrlChecker.accdb

اليك حل اخر بالاكواد لعله يفيد حضرتك وممكن تعدل عليه علي حسب رغبه حضرتك Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim hijriDate As String ' تعيين الورقة النشطة Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير اسم الورقة إذا كان مختلفًا ' التحقق إذا كان التغيير في النطاق X3 إلى آخر خلية تحتوي على بيانات If Not Intersect(Target, ws.Range("X3:X" & ws.Cells(ws.Rows.Count, "X").End(xlUp).Row)) Is Nothing Then ' العثور على آخر صف يحتوي على بيانات في العمود X lastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row ' تكرار عبر الصفوف من X3 إلى آخر صف For i = 3 To lastRow ' قراءة التاريخ الهجري من الخلية hijriDate = ws.Cells(i, "X").Value ' التحقق إذا كانت الخلية تحتوي على تاريخ If hijriDate <> "" Then ' التحقق إذا كان حرف "هـ" موجودًا بالفعل If InStr(hijriDate, "هـ") = 0 Then ' تحويل التاريخ إلى التنسيق المطلوب وإضافة حرف "هـ" ws.Cells(i, "X").Value = Format(hijriDate, "yyyy/mm/dd") & "هـ" End If End If Next i End If End Sub مثل التاريخ.xlsm

الاداة مفتوحة المصدر 😎 يمكنك التعديل وتقديم الحلول والاقتراحات ================================================== تحديث على الصوااريخ 😂 1- ربط ملف الاكسس لكل تعديل تحديث تلقائي وليس تحرير كتابة وقراءة فقط 2- جمع Sum (A:A) جمع المليارات من نص اكسس الى ملف اكسل ورجوع للنص اكسس (( بالملايين )) 3- تنقل وعرض الملفات تحميل بالمرفق : Number_Miluon_Sum_With_Link_Excel_On_MsAccess.rar