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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 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 وهذه صورة للبرنامج :-

اكتب التسمية التوضيحية العربية للحقول ثقافتي ضعيفة في اللغات

استدراك : جدول التقييم : المفتاح مشترك بين حقل السنة وحقل الشهر وحقل رقم الموظف هذا اذا اردنا الضبط من خلال الجدول ويمكن ضبط عدم التكرار بالكود لمن لا يرغب في تقييد الجدول

تمام هذه يمكن التحكم بها من خصائص الحقل بحيث لا تزيد عن الدرجة المقررة يلزمك الآن اعداد برنامجك على النحو التالي : جدول الاسماء ( مفتاح (ترقيم تلقائي) / رقم الموظف / اسمه / اي بيانات اخرى ) جدول للشهور ( رقم الشهر (مفتاح) / اسم الشهر ) جدول التقييم ( مفتاح (ترقيم تلقائي) / حقل السنة (رقمي) / حقل الشهر (رقمي) /رقم الموظف/ حقول التقييم الاربعة (القيمة الافتراضية صفر) ) هذا ما اتصوره الآن

لم افهم هل تقصد مثلا بـــ 0/4 اي انه حصل على صفر من اربعة و 2/4 حصل على اثنين من اربعة ؟ بمعنى ان الدرجة القصوى هي 4 ؟ ومثلها 0/12 و 0/6 ؟

من أسباب عدم نجاح العلاقة بين الجدولين في الصورة .. وجود تكرار في البيانات في الجدول الذي ترغب بجعله مفتاحًا أساسيًا (Primary Key) عند الربط بين جدولين ، يجب أن تكون البيانات في الحقل المرتبط فريدة ( بدون تكرار ) إذا كنت تريد إنشاء علاقة من نوع ( One-to-Many ) . إذا كان هناك تكرار في هذا الحقل ، ستظهر رسالة خطأ . وجود سجلات لا تتطابق بين الجدولين إذا كنت تحاول إنشاء علاقة حيث يجب أن تتطابق القيم بين الجدولين ، ستواجه مشكلة إذا كانت هناك سجلات في أحد الجدولين لا يوجد لها سجلات مقابلة في الجدول الآخر . أنواع بيانات غير متطابقة يجب أن يكون نوع البيانات في الحقول المرتبطة متطابقًا ، مثلًا: إذا كان أحد الحقول "رقم" فيجب أن يكون الحقل الآخر "رقم" أيضًا ، وإلا ستظهر رسالة خطأ . وجود بيانات غير صحيحة أو غير صالحة أحيانًا ، تكون البيانات في الحقول مرتبطة بالقيم الافتراضية أو الحقول المحذوفة ، مما يتسبب في مشكلة عند محاولة الربط . هذا بشكل عام قد يكون أحدها أو معظمها سبباً في عدم نجاح العلاقة بين الجدولين . هذا والله أعلم

تفكيرك يدور في محيط آكسل ليس شرطا ان يتم عرض الشهور و البيانات افقيا يفي بالغرض جدول واحد يشتمل على : ( حقل للسنة / قل للشهر / قل لاسم الموظف / حقول الدرجات .) قد تحتاج الى حقل رقمي او نصي للتصنيف والتجميع كل موظف سيكون له في نهاية السنة 12 سطرا (سجلا) كل سطر عبارة عن شهر انا اعتقد ان هذا كل شيء .. وانه يمكنك في النهاية اظهار المخرجات على صور شتى حسب الرغبة

تمام بارك الله فيك وجزاكم الله خيرا المشكلة هى عدم الإعلان عن المتغيرات بإضافة Option Explicit لتحديد نوع المتغيرات فقط لا غير شاكر فضل حضرتك على ما قدمته فى هذا الموضوع تقبل وافر التحية والتقدير

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

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

السلام عليكم حسب فهمى لطلبك انك تكتب في الخلية A1 يبقى الكود ثانية ثم ينتقل الى الخلايا التي بعدها في نفس العمود والفارق الزمني ثانيةواحدة بين نقلة واخري الكود ينتقل الى اخر خلية فيها بيانات ثم يتوقف يمكن تعديل الزمن في الكود الى اي مدة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Me.Range("A1")) Is Nothing Then If Target.Value <> "" Then Application.OnTime Now + TimeValue("00:00:01"), "MoveToNextCellContinuously" End If End If End Sub Sub MoveToNextCellContinuously() Static NextCell As Range On Error Resume Next If NextCell Is Nothing Then Set NextCell = Worksheets("Sheet1").Range("A2") Else Set NextCell = NextCell.Offset(1, 0) End If If NextCell.Row <= Worksheets("Sheet1").Rows.Count And NextCell.Value <> "" Then NextCell.Select Application.OnTime Now + TimeValue("00:00:01"), "MoveToNextCellContinuously" End If End Sub الملف 011.xlsm

لا أعلم ما تحاول فعله لاكن جرب وضع الكود التالي في Module Public Sub RunCode() Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.OnKey "{F10}", "RunCode" End Sub '==================== Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F10}" End Sub بهذه الطريقة بعد إظافة رقم الإدخال يمكنك تشغيل الكود باستخدام زر F10 فقط من لوحة المفاتيح (يمكنك تعيدله بما يناسبك ) ولا يستجيب أثناء التنقل أو تحديد خلايا أخرى 2.xlsm

مساءك فل .... ممكن الشكل المتوقع تصديرة .... هل تريد كل سائق وامامه بياناته ومع الاصول التي تخصه ... يعني مثلا سائق لديه ثلاث سيارات اصول ... هل تريدها في ثلاث سجلات ... ام سجلات مدمجة ؟؟؟؟

أخي الكريم @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 - تغير الإعدادات - تغير الطابعة الإفتراضية - عدم السماح للوندوز بتجاوز إختيار - فيما أذكر يمكن التحكم بالطابعة الإفتراضية من خلال الريجيستري كعمل بروفايل خاص بإعدادات خاصة أرجو لكم التوفيق والسداد والتعامل مع الريجيستري بحذر ويفضل دائماً أخذ نسخة احتياطية للأمان

هذا بالمعادلات VLOOKUP عرض سند بواسطة الكود.xlsx وهذا بالأكواد بعد تسريع الكود ولك حرية الاختيار VLOOKUP عرض سند بواسطة الكود.xlsb

بحث بالاسم في تيكست بوكس.xlsm

استخدم هذه المعادلة في خلية K12 أو أي خلية أخرى =MAXIFS(Table1[RATE];Table1[Order Date :];"<"&$H$4;Table1[Item Code];E12)

لأنك غيرت بالمعادلة اللي باللون الأحمر زيادة =IFERROR(_xlfn.SINGLE(INDEX(Table2[كمية سابقة];AGGREGATE(15;6;((1)/(Table2[جارى]=$H$2))*(ROW($A$1:$A$301));ROW(A1));1));"") المرفق بعد التعديل مستخلص مياه ورمل (3).xlsx

في هذا البرنامج بالذات أتعبت الأكسل وأتعبني كان التحدي أن يتم العمل بدون أكواد فيجول فقط بالدوال والتنسيق الشرطي والارتباط التشعبي أدعو الله أن أكون فيه موفقا وأن يفيد ولو واحدا من إخواني المسلمين البرنامج فيه خبايا وأسرار خلف الستار للمهتمين بالأكسل . تأجير الشقق.xlsx

تم التطبيق على الملف المرفق ، وهو يعمل بصورة جيده وفقكم الله حركة2018.rar

السلام عليكم ورحمة الله تفضل مجموع بين تاريخين.rar

السلام عليكم ورحمة الله تفضل ...... عذرا على التأخير مجموع بين تاريخين.rar