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

ما شاء الله ، تبارك الله .. أفكار وحلول جميلة ، من الأساتذة ( @hegazee ، @محمد هشام. ... ) ، ولهذا وددت أيضاً تطوير الفكرة بحيث عند وجود أكثر من فارق بين ( قبل وبعد ) في نفس الصف ، ان يتم تمييز كل فارق بلون مختلف لتسهل معرفة وتتبع الفروقات عند السجلات الكبيرة . حيث تم تعديل الدالة الرئيسية فقط كالآتي :- Public Sub HighlightGradeDifferencesGeneral(ByVal sheetObject As Worksheet, _ ByVal rangeBeforeAddress As String, _ ByVal rangeAfterAddress As String, _ Optional ByVal showMessage As Boolean = True) Dim rangeBefore As Range Dim rangeAfter As Range Dim cellAfter As Range Dim cellBefore As Range Dim i As Long Dim j As Long Dim colorPalette As Variant Dim colorIndex As Long colorPalette = Array(6, 3, 4, 7, 8, 9, 10, 12) On Error GoTo ErrorHandler Set rangeBefore = sheetObject.Range(rangeBeforeAddress) Set rangeAfter = sheetObject.Range(rangeAfterAddress) If rangeBefore.Rows.Count <> rangeAfter.Rows.Count Or _ rangeBefore.Columns.Count <> rangeAfter.Columns.Count Then If showMessage Then MsgBox "نطاق 'قبل' (" & rangeBeforeAddress & ") ونطاق 'بعد' (" & rangeAfterAddress & ") " & _ "في الورقة '" & sheetObject.Name & "' ليسا بنفس الأبعاد . يرجى التحقق", vbExclamation + vbMsgBoxRight, "" End If Exit Sub End If Application.EnableEvents = False Application.ScreenUpdating = False rangeBefore.Interior.colorIndex = xlNone rangeAfter.Interior.colorIndex = xlNone For i = 1 To rangeAfter.Rows.Count colorIndex = 0 For j = 1 To rangeAfter.Columns.Count Set cellAfter = rangeAfter.Cells(i, j) Set cellBefore = rangeBefore.Cells(i, j) If Not IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value) Then If cellAfter.Value <> cellBefore.Value Then cellAfter.Interior.colorIndex = colorPalette(colorIndex) cellBefore.Interior.colorIndex = colorPalette(colorIndex) colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1) End If ElseIf (IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value)) Or _ (Not IsEmpty(cellAfter.Value) And IsEmpty(cellBefore.Value)) Then cellAfter.Interior.colorIndex = colorPalette(colorIndex) cellBefore.Interior.colorIndex = colorPalette(colorIndex) colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1) End If Next j Next i If showMessage Then MsgBox "اكتملت المقارنة وتم تلوين الاختلافات في الورقة '" & sheetObject.Name & "'.", vbInformation + vbMsgBoxRight, "" End If ErrorHandler: Application.ScreenUpdating = True Application.EnableEvents = True If Err.Number <> 0 And showMessage Then MsgBox "حدث خطأ في الورقة '" & sheetObject.Name & "': " & Err.Description, vbCritical + vbMsgBoxRight, "" End If End Sub الملف بعد إضافة التعديل درجات المواد.xlsm وصورة توضيحية للنتيجة

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى أحب التنويه فقط أن كود الأستاذ @Foksh أكثر ديناميكية ومرونة لأنه يعتمد على دالة عامة تستقبل نطاقات متعددة مما يسمح باستخدامه لأي نطاق وفي أي ورقة دون الحاجة إلى تعديل داخلي في الكود بينما الكود الحالي مخصص لنطاق محدد وثابت داخل ورقة العمل وتم تقييده حسب البيانات الموجودة لديك في الملف هذا يجعل الكود أبسط وأسرع في التنفيذ لكنه أقل مرونة من حيث التعديل أو الاستخدام مع نطاقات مختلفة أو أوراق أخرى مستقبلا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, j As Long, Tbl1 As Range, Tbl2 As Range Dim a As Range, b As Range, tmp As Range Dim xColor As Long: xColor = RGB(255, 204, 0) Dim ColArr As Long: ColArr = 8 Dim départ As Long: départ = 12 Dim début As Long: début = 3 On Error GoTo CleanExit Set Tbl1 = Range("B" & début).Resize(départ, ColArr) Set Tbl2 = Range("K" & début).Resize(départ, ColArr) If Intersect(Target, Union(Tbl1, Tbl2)) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False For Each tmp In Intersect(Target, Union(Tbl1, Tbl2)) i = tmp.Row - début + 1 If i >= 1 And i <= départ Then For j = 1 To ColArr Set a = Tbl1.Cells(i, j) Set b = Tbl2.Cells(i, j) If a.Value <> b.Value Then a.Interior.Color = xColor b.Interior.Color = xColor Else a.Interior.ColorIndex = xlNone b.Interior.ColorIndex = xlNone End If Next j End If Next tmp CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub درجات المواد v3.xlsb

وعليكم السلام ورحمة الله وبركاته ,, يوجد طريقة بالتنسيق الشرطي قد تكون فكرة أحد الأساتذة ، ولكني اتجهت الى سلوك آخر من خلال VBA مع إضافة المرونة في الإستخدام لأكثر من ورقة ، وكل ورقة بنطاقات مختلفة .. في مديول جديد يتم اضافة الكود التالي :- Public Sub HighlightGradeDifferencesGeneral(ByVal sheetObject As Worksheet, _ ByVal rangeBeforeAddress As String, _ ByVal rangeAfterAddress As String, _ Optional ByVal showMessage As Boolean = True) Dim rangeBefore As Range Dim rangeAfter As Range Dim cellAfter As Range Dim cellBefore As Range Dim i As Long Dim j As Long Dim highlightColor As Long On Error GoTo ErrorHandler Set rangeBefore = sheetObject.Range(rangeBeforeAddress) Set rangeAfter = sheetObject.Range(rangeAfterAddress) highlightColor = 6 If rangeBefore.Rows.Count <> rangeAfter.Rows.Count Or _ rangeBefore.Columns.Count <> rangeAfter.Columns.Count Then If showMessage Then MsgBox "نطاق 'قبل' (" & rangeBeforeAddress & ") ونطاق 'بعد' (" & rangeAfterAddress & ") " & _ "في الورقة '" & sheetObject.Name & "' ليسا بنفس الأبعاد . يرجى التحقق", vbExclamation + vbMsgBoxRight, "" End If Exit Sub End If Application.EnableEvents = False rangeBefore.Interior.ColorIndex = xlNone rangeAfter.Interior.ColorIndex = xlNone For i = 1 To rangeAfter.Rows.Count For j = 1 To rangeAfter.Columns.Count Set cellAfter = rangeAfter.Cells(i, j) Set cellBefore = rangeBefore.Cells(i, j) If Not IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value) Then If cellAfter.Value <> cellBefore.Value Then cellAfter.Interior.ColorIndex = highlightColor cellBefore.Interior.ColorIndex = highlightColor End If ElseIf (IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value)) Or _ (NotEmpty(cellAfter.Value) And IsEmpty(cellBefore.Value)) Then cellAfter.Interior.ColorIndex = highlightColor cellBefore.Interior.ColorIndex = highlightColor End If Next j Next i If showMessage Then MsgBox "اكتملت المقارنة وتم تلوين الاختلافات في الورقة '" & sheetObject.Name & "'.", vbInformation + vbMsgBoxRight, "" End If ErrorHandler: Application.EnableEvents = True If Err.Number <> 0 And showMessage Then MsgBox "حدث خطأ في الورقة '" & sheetObject.Name & "': " & Err.Description, vbCritical + vbMsgBoxRight, "" End If End Sub Function NotEmpty(cellValue As Variant) As Boolean NotEmpty = Not IsEmpty(cellValue) End Function وفي حدث Worksheet_Change للورقة التي تريدها ، نستخدم الاستدعاء بالشكل التالي :- Private Sub Worksheet_Change(ByVal Target As Range) Dim watchRangeBefore_Sheet1 As Range Dim watchRangeAfter_Sheet1 As Range Dim ws As Worksheet Set ws = Me ' --- حدد النطاقات الخاصة بـ Sheet1 --- Dim beforeAddress_Sheet1 As String Dim afterAddress_Sheet1 As String beforeAddress_Sheet1 = "B3:I14" ' نطاق "قبل" في Sheet1 afterAddress_Sheet1 = "K3:R14" ' نطاق "بعد" في Sheet1 On Error GoTo SafeExit Set watchRangeBefore_Sheet1 = ws.Range(beforeAddress_Sheet1) Set watchRangeAfter_Sheet1 = ws.Range(afterAddress_Sheet1) If Not Intersect(Target, watchRangeBefore_Sheet1) Is Nothing Or _ Not Intersect(Target, watchRangeAfter_Sheet1) Is Nothing Then Call HighlightGradeDifferencesGeneral(sheetObject:=ws, _ rangeBeforeAddress:=beforeAddress_Sheet1, _ rangeAfterAddress:=afterAddress_Sheet1, _ showMessage:=False) End If SafeExit: If Err.Number <> 0 Then End If End Sub لاحظ أنه في كود الاستدعاء داخل الورقة التي تريد التطبيق عليها ، تستطيع تحديد النطاق من - إلى كيفما تشاء ، وطبعاً مع ضرورة تغيير اسم الورقة بدلاً من Sheet1 إلى اسم الورقة الثانية في حال اري الاستدعاء في أكثر من ورقة . هذا سيضمن لك الإستدعاء مع التحديد النطاق ( قبل و بعد ) لكل ورقة ولكن بدالة واحدة مرنة . الملف بعد التطبيق :- درجات المواد.xlsm

جداوله مكتملة وافية .. فقط بحاجة الى اعادة تنسيق كما ذكر اخونا @Foksh

كود رائع للاستاذ @Foksh إليك حل آخر بالتنسيق الشرطي درجات المواد(2).xlsx

اعرض الملف 📅📚🔥>> لعبة مطابقة الأرقام 2 :: لتنمية مهارة التركيز 😉👌 <<🧮🌟 :: الإصدار الثاني المطور 😎✌ :: السلام عليكم ورحمة الله وبركاته 🙂 🖐🌷 :: عدنا إليكم بالإصدار المطور من اللعبة الجميلة 😊🎁 🧮📚>> لعبة مطابقة الأرقام 2.0 <<📚🧮 ملخص اللعبة هو : اللعبة تعطيك رقم عشوائي وكل ما عليك فعله هو إعادة كتابة الرقم من خلال لوحة الأزار التي أمامك أو من خلال أزرار الكيبورد في زمن محدد 😊🖐 .... أنتظر .. هذا ليس كل شيء .. !! 😉 ستخوض تحدي حقيقي هذه المرة خلال عبورك عشر مستويات من الإثارة والمتعة .. حيث أن في كل مستوى سوف يتم إعادة توزيع الأرقام في الأزرار بشكل عشوائي وكذلك عدد الأرقام يزداد والزمن المحدد يقل مما يزيد الإثارة في كل مستوى .. 😁👌 :: مميزات اللعبة والتحديثات الجديدة :: * يمكن اللعب بشكل فردي أو بشكل جماعي (أكثر من لاعب) * * مرحلة تدريبية قبل الشروع في المستوى الأول * * يمكن التنقل بين المستويات العشرة * * تصميم جميل وأنيق ولعبة شيقة تعينك على تمرين مهارة التركيز لديك * وهذه لقطات مختلفة من اللعبة : ::🌷 شكر وتقدير 🌷:: للأخالعزيز المهندس فادي @Foksh لتطويره اللعبة بالشكل الحالي وإضافة أفكاره النيرة ولمساته الرائعة 😊🌹 :: وختاما .. لا تنسونا من صالح دعواتكم 😊🤲:: صاحب الملف Moosak تمت الاضافه 06/04/25 الاقسام قسم الأكسيس  

وعليكم السلام ورحمة الله وبركاته .. استعملت استعلام تحديث بعد اضافة الحقل النصي LinkTxt في الجدول ، فيقوم بتحديث قيمة الحقل لكل سجل باستخراج اسم الموقع على شكل نص وليس رابط تشعبي . UPDATE Linktbl SET Linktbl.LinkTxt = HyperlinkPart([LinkName], 1) WHERE Linktbl.LinkName IS NOT NULL; LinkName.accdb

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @Foksh بناء على هده الفكرة القيمة قمت بتطوير الكود بحيث عند وجود أكثر من اختلاف بين القيم (قبل وبعد) يتم تمييز كل اختلاف بلون مختلف هذا فعلا يسهل جدا معرفة وتتبع الفروقات كما دكرت مع إظافة استخراج المادة التي تحتوي على الاختلاف إلى جانب الاسم والقيمة القبلية والبعدية لتوفير عرض واضح ومباشر للفروقات بالتوفيق......... نسخة معدلة من الكود لتحقيق هذا الهدف Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Long, c As Long, Tbl1, Tbl2, a, b, tmp As Long, xCount As Long, key As String Dim xColor, cnt As Object, j As Long, i As Long, x As Long, ky As String Const départ = 3, ColArr = 18, début = 2, LastCol = 9, f = 9, Irow = 1 If Target.CountLarge > 1 Then Exit Sub Set cnt = CreateObject("Scripting.Dictionary") xColor = Array( _ RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 176, 80), RGB(0, 112, 192), RGB(255, 192, 0), RGB(112, 48, 160), _ RGB(255, 0, 255), RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 102, 0), RGB(204, 0, 153), RGB(0, 255, 255), _ RGB(255, 153, 204), RGB(153, 51, 0), RGB(102, 102, 255), RGB(255, 204, 153), RGB(51, 153, 102), RGB(153, 0, 0), _ RGB(0, 102, 204), RGB(204, 153, 255), RGB(255, 255, 153), RGB(204, 0, 0), RGB(0, 153, 0), RGB(0, 51, 102), _ RGB(255, 128, 0), RGB(102, 0, 102), RGB(0, 204, 204), RGB(255, 102, 102), RGB(102, 255, 102), RGB(102, 102, 153)) On Error GoTo CleanUp With Me If Intersect(Target, .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f))) Is Nothing Then Exit Sub SetApp False .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f)).Interior.colorIndex = xlNone With .Range("T:W"): .UnMerge: .ClearContents: End With Me.[T1:W1].Value = Array("الإسم", "المادة", "قبل", "بعد") tmp = 2: j = 0: xCount = 0 For r = départ To départ + ColArr - 1 b = .Cells(r, Irow).Value For c = début To LastCol Tbl1 = .Cells(r, c).Value: Tbl2 = .Cells(r, c + f).Value: a = .Cells(2, c).Value If IsEmpty(Tbl1) Then Tbl1 = "" If IsEmpty(Tbl2) Then Tbl2 = "" If CStr(Tbl1) <> CStr(Tbl2) Then xCount = xCount + 1 key = b & "|" & a & "|" & Tbl1 & "|" & Tbl2 If Not cnt.Exists(key) Then cnt.Add key, xColor(j Mod (UBound(xColor) + 1)) j = j + 1 End If .Cells(r, c).Interior.Color = cnt(key) .Cells(r, c + f).Interior.Color = cnt(key) .Cells(tmp, "T").Resize(1, 4).Value = Array(b, a, Tbl1, Tbl2) tmp = tmp + 1 End If Next c Next r If xCount > 0 Then .Cells(tmp, "T").Value = "إجمالي الاختلافات" .Cells(tmp, "U").Value = xCount x = 2: ky = .Cells(x, "T").Value For i = 3 To tmp If .Cells(i, "T").Value <> ky Or .Cells(i, "T").Value = "" Then If i - 1 > x Then .Range("T" & x & ":T" & i - 1).Merge x = i ky = .Cells(i, "T").Value End If Next i Else With .Range("T:W"): .UnMerge: .ClearContents: End With End If CleanUp: SetApp True Set cnt = Nothing End With End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub درجات المواد v4.xlsb

السلام عليكم انا مررت سريعا ولكن الى ان اعود مرة اخرى لانشغالى الشديد الان انظر الى هذا المرفق ان شاء الله تعالى قد تجد فيه افكار قد تعجبكم الذكر الحكيم.zip

أنت اللي حاط الوقت .. تصرف !! 😂😅

الشكر لله وحده من قبل ومن بعد على ما علمنا العفو يا مهندسنا الغالي ، ما هي إلا إبداعاتكم وتوجيهاتكم وتنسيقاتكم وأفكاركم ولا انت خايف يطلع حد خسران ويحكي ان اللعبة خسرته ويجي عندك يقولك مصعبها علينا 😂 جزاكم الله خيراً على ابداعاتكم ، وفعلاً لعبة مسلية وتساعد على التركيز ، ولكن 😤 !!!!! أحياناً يا أخي ما ألحق الوقت وأخسر 😭

تحياتي للأساتذه @Foksh و @محمد هشام. على الحلول الرائعة. و إثراء للموضوع و استكمالا لما قدمه الأساتذة أقدم إضافة بسيطة لترحيل الاختلافات درجات المواد v4.xlsb

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

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

بارك الله فيك وجعله في ميزان حسناتك . وعيد اضحى كريم عليك

بقي لك 3 مشاركات فقط .. لتتمكن من استخدام الرسائل الخاصة

العفو أخي الكريم @algammal سعدنا دائما بمشاركتنا في إثراء الموضوع وتقديم الاقتراحات التي تساعدك على تحقيق النتائج المطلوبة والشكر الكبير للأستاذ الفاضل عبد الله على جهوده القيمة ومساهمته المتميزة بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير مع ذلك لديك الآن عدة طرق مختلفة وجميعها فعالة ويمكنك اعتماد الأنسب منها حسب طبيعة عملك واحتياجاته

وعليكم السلام ورحمة الله وبركاته 4 طرق لمسح البيانات 1- زر به كود مسخ البيانات (جديد) يقوم الزر بنفس وظيفة الخلية الفارغة 2- اخنيار الخلية الفارغة من E5 (بعد عمل زر المسخ ليس لها ضرورة ) 3- الخروج من شيت SEARCH ثم العودة اليه 4- النقر مرتين في اي خلية في شيت SEARCH وايسرها كما تفضلتم زر المسح او النقر مرنين كما انوه ان تحديث البيانات اظافة وظيفة جديدة ..... الخ الى شيت DATA او معاشات يتم تلقائيا مع الانتباه لزيادة مدى البيانات للقائمة من التحقق من صحة البيانات انمنى اتى قدمت ما بقيد وما زال الباب مفتوحا لمفترحاتكم او ملاحظاتكم وكل عام وانتم بالف خير طريقة اخرى للبحث معدلة7.xlsb

وعليكم السلام ورحمة الله وبركاته .. حاولت أن أفهم وأن أتبين الغرض والهدف من طلبك ، ولكني لم أنجح ولم أفلح في تخيل الهدف من هذه الحركة عند فتح التقرير . على العموم .. لجعل التركيز على الكومبوبوكس اللي في النموذج List ( وأعتقد أنه من الأسماء المحجوزة لآكسيس ) ، يجب أن نجعل خاصية Modal = Yes للنموذج ، وحيث أننا لا نريد تغيير الخصائص للنموذج بشكل دائم ، فهنا يمكننا استخدام الدالة WindowMode طبعاً مع تحديد نوع أو نمط فتح النموذج بحيث تكون = WindowMode:=acWindowNormal . وعليه فأن الكود النهائي في حدث عند التحميل للتقرير سيكون كالآتي :- Private Sub Report_Load() DoCmd.OpenForm "List", WindowMode:=acWindowNormal Forms("List").Modal = True Forms("List").Combo0.SetFocus End Sub جربه في تقريرك ، وأخبرنا بالنتيجة .

وعليكم السلام ورحمة الله وبركاته ملفك لا بحتوى على اي كود تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb