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

وعليكم السلام ورحمة الله تعالى وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الكود التالى فى وحده نمطية عامة Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function SetTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _ ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long #Else Private Declare Function SetTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long #End If Private lngTimerID As LongPtr Private frmTargetClock As Form Public Sub StartSystemClock(frm As Form) Set frmTargetClock = frm lngTimerID = SetTimer(0, 0, 1000, AddressOf TimerProc) End Sub Public Sub StopSystemClock() If lngTimerID <> 0 Then KillTimer 0, lngTimerID lngTimerID = 0 End If End Sub Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) If Not frmTargetClock Is Nothing Then frmTargetClock!lblClock.Caption = Format(Now, "hh:nn:ss AM/PM") Else StopSystemClock End If End Sub الاحدات فى النموذج Option Compare Database Option Explicit Private Sub Form_Load() Call StartSystemClock(Me) End Sub Private Sub Form_Unload(Cancel As Integer) Call StopSystemClock End Sub المرفق Clock Without Timer Event.accdb

أخواني وأساتذتي ومعلمينا ( دون استثناء ) الكثير من المواضيع التي قد تكون تطرقت الى هذا الموضوع ولكن بطرق وأشكال مختلفة . اليوم وفقط في أوفيسنا / آكسيس ، سأقدم لكم نظام كامل متكامل لإدارة الطابور والدور الذي يمكن استخدامه في أي منشئة تجارية تتعامل بهذا النظام . من المعروف أننا عندما ندخل مركز للصرافة على سبيل المثال ، فإن العميل يحصل على رقم دور مطبوع على شكل تذكرة يحتفظ بها لحين تفرغ موظف لتلبية طلبه وخدمته . وعند انتظارك كعميل لحين وصول الدور لك فإنك تراقب شاشة الدور لمعرفة أين وصل الدور لأي تذكرة . وطبعاً ما يميز هذا النظام أنك في حين لم تكن متابعاً لشاشة العرض فإن النظام الصوتي كفيل بتنبيهك أين وصل الدور ولأي شباك موظف . إلى هنا وكل هذا متاح لك اليوم مع نظام مراقبة الطابور والدور الجديد . وسنسير بشرح المكونات تسلسلاً وشرحاً وافياً ( دون الإطالة .. ) أولاً :- واجهة حجز الدور الذي سيبدأ منها العميل بأخذ دور له ، وهي ذات واجهة بسيطة فقط زر واحد ينقره العميل للحصول على رقم دوره . مرفق تالياً صورة الواجهة ، والتي تدعم بالطبع شاشة اللمس . أي أن ما على العميل فقط هو النقر على الزر "احصل على رقم دور جديد" . ثانياً :- وبعد أن حصل العميل على دوره ، سيراقب دوره في قاعة الإنتظار على شاشة عرض الأدور ، والتي بدورها ستخبر العميل الى أي شباك موظف عليه التوجه حين يحين دوره ، وطبعاً لإرضاء الرغبات قمت بإضافة ميزة الناطق الصوتي ( عربي - انجليزي "اللغة الإفتراضية" ) . أي أنه عليك - كمستخدم أو مصمم - لاحقاً تفعيل اللغة العربية الصوتية (Text-to-speech) . وهنا نقطة مهمة يجب أن نمر عليها سريعاً كي تتوضح لك عزيزي القارئ كيف يمكن تفعيل القارئ الصوتي العربي للنصوص . لذا هذا الفيديو يوضح الخطوات الأولى لإضافة اللغة العربية الصوتية إلى ويندوز 10 . النقطة المزعجة من مايكروسوفت أنه وللأسف لا يتم فعلاً إضافة هذه التثبيتات الى مكانها الصحيح في محرر الريجستري . لذا علينا فعل ذلك بالطريقة اليدوية لضمان تشغيل القارئ الصوتي العربي . لذا ولمحة سريعة سنتطرق للموضوع بشكل مختصر :- بعد الذهاب إلى محرر الريجستري + R اكتب كلمة regedit اذهب الى المسار التالي : Computer\HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Microsoft\Speech_OneCore\Voices\Tokens قم بتصدير هذا المفتاح كاملاً الى سطح المكتب بأي اسم تريده . افتح ملف الريجستري هذا باستخدام المفكرة Notepad . قم بإزالة الجزء "_OneCore" من جميع المسارات الموجودة أمامك . احفظ الملف ، وافتحه واختر Yes - نعم من الرسالة التي ستظهر لك مرتين ( على ما أعتقد ) . مبروك عليك تفعيل الناطق العربي . لك حرية الإختيار بتفعيل اللغة العربية أو لا ، ويمكنك الإنتقال لباقي الشرح . تابع معي :- الآن جاء دور الموظفين الذي سيكون لهم جميعهم نموذج واحد بنفس الأكواد بدون أي فرق لا في الشكل ولا في طريقة العمل ، انظر الصورة لاستكمال الشرح :- صورة لواجهة الموظف ( الشباك 1 ) والأمر نفسه لباقي الموظفين . ماذا يمكن للموظف أن يفعل هنا ؟ فقط النقر على الزر الذي سيكون مفعلاً عند وجود عملاء في الإنتظار ( استدعاء التالي & عدد العملاء الذين في الإنتظار ) كما في الصورة التالية :- فقط بعد النقر سيتم استدعاء العميل الأول في الانتظار ( حسب وقت الحجز طبعاً ) الى الشباك 1 :- طبعاً من المزايا المتاحة للموظف ، تحويل عميله الى موظف آخر ( ذو اختصاص على سبيل المثال ) ... إلخ . أو أن يطلب استراحة ( عند عدم انشغاله في عميل ) بأن يكون غير متاح في هذه الفترة لتلقي العملاء .... إلخ . وأيضاً بدء وانهاء خدمة العميل . وطبعاً الأمر ينطبق على جميع الموظفين . ثالثاً :- لوحة عرض العملاء في الإنتظار ، ذات واجهة بسيطة ومريحة كالتالي :- ليس بها أي تعقيد أو أمور تتطلب اعدادات أو ضبط خاص . رابعاً :- شاشة تحكم المدير ، وبهذه الواجهة سنشرحها في نقاط .. الجهة اليمنى تمثل إحصائيات واضحة للمدير عن تفاصيل حركة الدور ... الأزرار في أسفل يمين الشاشة تمثل :- • زر مخصص لتفعيل / تعطيل الناطق الصوتي لرقم الدور . • زر تحديث يدوي = تحديث للتفاصيل الظاهرة للشاشة بشكل يدوي . • زر تعيين القيمة التلقائية للتحديث = عند النقر عليه سيتم اظهار قائمة بسيطة تمثل رقم الدقائق التي تريد للنظام أن يتم تحديثه بشكل تلقائي دون الحاجة الى التحديث اليدوي . • زر إنهاء جميع العملاء العالقين = للطواري في حين حدوث أي خلل أو انقطاع الكهرباء أو الخروج لأي موظف دون انهاء عميله ، أو وجود عملاء لهم حجز وليسوا موجودين ... إلخ . الجهة اليسرى العلوية وتمثل العملاء الذين في الانتظار ( رقم الدور و الوقت الذي تم الحجز فيه ) . الكومبوبوكس الذي يمثل الموظفين المتاحين الآن ، وعند اختيار اي موظف سيتم عرض حالته ( متفرغ - في استراحة - يخدم عميل رقم .. ) وهنا تأتي صلاحيات المدير بأن يقوم بتحويل عميل هذا الموظف الى عميل محدد أو إعادته إلى حالة الإنتظار ( وهنا سيكون لهذا العميل الحق بالوصول لأول موظف متفرغ "VIP" ) .أو أن يتم من الإدارة إنهاء خدمة العميل الذي يخدمه الموظف الذي تم اختياره . إمكانية عرض الساعة باللغتين العربية والإنجليزية عند النقر على الساعة فقط . تم تقسيم قاعدة البيانات الى قواعد امامية وقاعدية بيانات خلفية ( للجداول المشتركة ) . وميزات كثيرة ستجدونها في هذا العمل المتواضع . Queue Management System.zip الإصدار الجديد 1.30

السلام عليكم ورحمة الله وبركاته الأخوة والأخوات الكرام تحية طيبة وبعد،،، يوجد بالمرفقات ثلاث ملفات بعد فك الضغط 1- نموذج الـ Html باسم {ahmosAutoHtmlTemplate_V10} وتحتاج إليه فقط اذا اردت التعديل او اضافة اي شي للنموذج بشكل دائم ولإضافتة داخل البرنامج : - قم بنسخ كامل المحتوي ثم قم بتشغيل الكود التالي : [Call splitAutoTableSections] 2- ملف نصي باسم {Text_Table_Sample} ويستخدم بنسخ محتواه ثم الضغ علي الزر [Convert Copied Text To html] بالنموذج يتضمن هذا الملف مثال لجدول محدد بالعلامات التالية \t ---> vbTab علامة الفصل بين الأعمدة \n ---> vbLf علامة فصل السطور داخل الخلية \r\n -> vbNewLine علامة السطر الجديد 3- البرنامج باسم {Ahmos_AutoHtmlTable} يقوم البرنامج بتحويل الجداول الداخلية باستخدام استعلامات الـ SQL الي صفحة ويب و اي جدول خارجي عن طريق نسخ الجدول بالكامل او إذا كان الجدول علي شكل نص تم تجميعة برمجياً يوجد أمثلة كما يمكنك التجربة علي اي ملف اكسيل مع بعض الصور بعض أهم النقاط : 1- داخل هذه الوظيفة { Public Function autoTblBody } يتم معالجة محتوي الخلية للجداول الخارجية وهنا تم إضافة بعض المعاير مثل إذا كان المحتوي رقم اقل او بساوي 5 يتم توسيطة داخل الخلية اذا كانت القيم TRUE or False / YES or No يتم التوسيط وتغير اللون إذا كانت بداية الخلية = او ' يتم إزالتها وكذلك الوظيفة الخاصة بالجداول الداخلية { Public Function sqlToHtmlTbl } 2- يمكن إضافة عمود فارغ علي صفحة الـ HTML باستخدام addRecNumField = True وهو يضيف عمود recNum وفائدة هذا العمود يوجد وظيفة داخل الـ JavaScript تقوم بعمل ترقيم تلقائي لهذا العمود يتم الترقيم التلقائي عن 1- فتح الصفحة 2- عند التصدير وذلك حتي يتم تعدل الارقام علي الصفوف الظاهرة فقط 3- عند عمل إلي للتصفية Clear Filters الوظيفة هي function renumberTableColumn(columnHeadName, filterOnly = false) ويمكن ان تستخدم لترقيم اي عمود بكتابة اسم العمود بدل من columnHeadName هكذا 'recNum' اما filterOnly تحدد إذا كنت تريد ترقيم الصفوف الظاهرة فقط ام كامل الصفوف false كامل الصفوف true الظاهرة فقط اي ما يتبقي بعد البحث او التصفية 3- وظيفة saveTable تمكنك من حفظ الصفحة مرة اخري وفائدتها هي ان تقوم بحفظ نسخة اخري من الصفحة بعد حذف أعمدة او تصيفة صفوف function saveTable(deleteHiddenRows = true) وهي بشكل افتراضي تقوم بحذف الصفوف الغير ظاهرة من النسخة وليس من الأصل 4- ستجد Optional ByVal constFileName As String = "", _ داخل الوظيفة { strTbltToHtml و sqlTbltToHtml } ويسخدم هذا في تعديل هذه القيمة داخل نموذج الـ Html $fileName$ <span id="fileName" style="display: none;">$fileName$</span> وفائدتة هي وجود وظيفة في الـ java script {getExportFileName} تقوم بتحديد اسم الملف عند التصدير وتقوم بإضافة الوقت والتاريخ له فاذا كانت القيمة هنا $fileName$ او فارغة سيتم استخدام قيمة افتراضية [ahmosExTable] وغير ذلك ستسخدم أغلب وظائف الـ java script قمت بها بمساعدة الـ AI ولكن الحمد لله فاهمها بنسبة كبيرة 😁 بالتوفيق Ahmos_AutoHtmlTable_Files.zip

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

كل عام وجميع منتسبي منتدانا الغالي (أوفيسنا) بخير وصحة وعافية أعاده الله علينا وعليكم وعلى أمتنا الاسلامية بالخير واليمن والبركات.

إلى أصحاب الفضل علينا؛ إلى من علمونا؛ وما زلنا نتعلم منهم منتدى أوفيسنا (Excle) الكرام الأستاذ الفاضل / @أ / محمد صالح الأستاذ الفاضل / @ابراهيم الحداد الأستاذ الفاضل / @Ali Mohamed Ali الأستاذ الفاضل / @عبدالله بشير عبدالله الأستاذ الفاضل / @محمد هشام. الأستاذ الفاضل / @Foksh السلام عليكم ورحمة الله وبركاته جميعا كل عام وأنتم جميعا بخير وصحة وسعادة بمناسبة عيد الأضحى المبارك أعاده الله عليكم وعلينا وعلى الأمة الإسلامية بالخير واليمن والبركات ملحوظة: (الأسماء مرتبة تصاعديا منذ أول رد علينا)

السلام عليكم ورحمة الله وبركاته 🌹 بكل فخر وسعادة، تتقدم إدارة منتديات أوفيسنا وكافة أعضائها الكرام بأحرّ التهاني والتبريكات للأخ العزيز فادي @Foksh بمناسبة ترقيته إلى درجة مشرف 👏🎖️ لقد أثبت حضورك وجهودك الملحوظة في دعم الأعضاء وتقديم الفائدة باستمرار، وكان لعطائك بصمة واضحة في رُقي المنتدى وتطوره 📈💡 ✨ نبارك لك هذه الترقية المستحقة، ونتمنى لك كل التوفيق والنجاح في مهامك الجديدة ضمن كوكبة الإشراف في فريق الموقع 🌟 🌟 أهلاً وسهلاً بك في فريق أوفيسنا، واثقين بأنك ستواصل تميزك وتألقك بإذن الله 🌈 مع أطيب التحيات والتقدير، إدارة منتديات أوفيسنا 💼🌟

وعليكم السلام ورحمة الله تعالى وبركاته data.xlsx

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @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

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

وعليكم السلام ورحمة الله وبركاته ,, حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :- Private Sub Btn_1_Click() Dim wsMain As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long Dim i As Long Dim targetCol1 As String, targetCol2 As String Dim sourceCol1 As String, sourceCol2 As String Set wsMain = ThisWorkbook.Sheets("F") Dim targetSheetName As String targetSheetName = wsMain.Range("F6").Value On Error Resume Next Set wsTarget = ThisWorkbook.Sheets(targetSheetName) On Error GoTo 0 If wsTarget Is Nothing Then MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, "" Exit Sub End If If wsMain.Range("G6").Value = "قوى" Then sourceCol1 = "L" sourceCol2 = "M" targetCol1 = "H" targetCol2 = "I" ElseIf wsMain.Range("G6").Value = "تامين" Then sourceCol1 = "O" sourceCol2 = "P" targetCol1 = "H" targetCol2 = "I" Else MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, "" Exit Sub End If wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row) For i = 6 To lastRow If wsTarget.Range(sourceCol1 & i).Value <> "" Then wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value End If If wsTarget.Range(sourceCol2 & i).Value <> "" Then wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value End If Next i MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, "" End Sub جرب المرفق وأخبرنا بالنتيجة .. BB.zip

طيب كفكرة ممكن تعمل الساعة لحالها في نموذج فرعي وتعمل الحدث في النموذج الفرعي بدون ما يأثر على أحداث النموذج الرئيسي 🙂 Clock In Sub Form.accdb

السلام عليكم ورحمة الله وبركاته الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف وخصوصا النطاقات K13:KJ - H14:H فهي ليس لها اهمية خسب ملفك المرفق اليك التعديل حسب فهمى لفكرة عمل ملفك يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) الكود Sub dahmour() Dim w As Workbook Dim L As Variant Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Dim colNum As Long Dim matched As Boolean Dim rng As Range, cellDate As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").Range("D2").Value If L = "" Then MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation Exit Sub End If r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row Set rng = w.Sheets("Galal").Range("E7:Z7") c = 0 For Each cellDate In rng If IsDate(cellDate.Value) And IsDate(L) Then If CDate(cellDate.Value) = CDate(L) Then c = cellDate.Column Exit For End If End If Next cellDate If c = 0 Then MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical Exit Sub End If If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then colNum = w.Sheets("Sheet2").Range("K4").Value Else MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation Exit Sub End If matched = False For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1) If Trim(cell.Value) <> "" Then For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2) If Trim(cell.Value) = Trim(cell2.Value) Then w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) matched = True Exit For End If Next cell2 End If Next cell If matched Then MsgBox "تم الترحيل بنجاح!", vbInformation Else MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation End If End Sub الملف غياب1.xlsm

اعرض الملف برنامج العطاء للعقارات الاصدار 3.7 برنامج العطاء للعقارات الاصدار 3.7 يتم تسجيل بيانات ملاك العقارات اولا ثم تسجيل عقود المستاجرين وتاريخ بداية الايجار وعمل توزيع لها ظهور الايجارات المستحقة في تقرير حسب تاريخ استحقاق الايجار - تقرير للمستاجر لبيان عدد مرات الايجار وغيرها - تقرير يظهر الشقق الغير مؤجرة - تقرير يظهر شقق وعقارات باسم الحي - تقرير يظهر شقق المالك والباقي تقدر تكتشفة بالبرنامج البرنامج يتم استعمالة في الايجارات للشقق والاراضي وغيرها لمن يعملون في مكاتب العقار صاحب الملف waleed907 تمت الاضافه 06/21/25 الاقسام قسم الأكسيس

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن أستادنا الفاضل @Foksh جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك Private Sub UserForm_Initialize() ComboBox1.Clear: Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets: ComboBox1.AddItem sh.Name: Next ListBox1.ColumnCount = 3: ListBox1.ColumnWidths = "70;70;200" End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Dim ShName As String, Addr As String ShName = ListBox1.List(ListBox1.ListIndex, 0) Addr = ListBox1.List(ListBox1.ListIndex, 1) Sheets(ShName).Activate Sheets(ShName).Range("A4:F" & Sheets(ShName).Rows.Count).Interior.ColorIndex = xlNone With Sheets(ShName).Range("A" & Range(Addr).Row & ":F" & Range(Addr).Row) .Interior.Color = vbCyan: .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 2) End Sub Private Sub TextBox1_Change() On Error GoTo Cleanup SetApp False Dim ws As Worksheet, Sh_Name As String, ky As String, LastRow As Long, LastCol As Long Dim OnRng As Variant, i As Long, j As Long, xCount As Long, CellAddress As String Sh_Name = ComboBox1.Value ky = Trim(TextBox1.Text) If Sh_Name = "" Or ky = "" Then ListBox1.Clear Label5.Caption = "عدد النتائج: 0" If Sh_Name <> "" Then Sheets(Sh_Name).Range("A4:F" & _ Sheets(Sh_Name).Rows.Count).Interior.ColorIndex = xlNone Me.TextBox2 = "" GoTo Cleanup End If Set ws = Sheets(Sh_Name) With ws LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column End With ListBox1.Clear ws.Range("A4:F" & ws.Rows.Count).Interior.ColorIndex = xlNone xCount = 0 OnRng = ws.Range(ws.Cells(4, 1), ws.Cells(LastRow, LastCol)).Value For i = 1 To UBound(OnRng, 1) For j = 1 To UBound(OnRng, 2) If InStr(1, OnRng(i, j), ky, vbTextCompare) > 0 Then xCount = xCount + 1 CellAddress = ws.Cells(i + 3, j).Address(False, False) ListBox1.AddItem Sh_Name ListBox1.List(ListBox1.ListCount - 1, 1) = CellAddress ListBox1.List(ListBox1.ListCount - 1, 2) = OnRng(i, j) ws.Range("A" & (i + 3) & ":F" & (i + 3)).Interior.Color = vbCyan Exit For End If Next j Next i Label5.Caption = "عدد النتائج: " & xCount Cleanup: SetApp True End Sub Private Sub UserForm_Terminate() Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = "": ListBox1.Clear End Sub Private Sub ComboBox1_Change() On Error Resume Next If ComboBox1.ListIndex = -1 Then Exit Sub TextBox1 = "": ListBox1.Clear Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next Sheets(ComboBox1.Value).Activate 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 ملاحظة :تم الاستغناء عن الكود Search_In_Sh() فأنت الآن لست بحاجة إليه بحث في عدة أوراق مع التحديد v2.xlsm

ببساطة أخي @زياد الحسناوي بعد إضافة الأرقام الجديدة لم تقم بسحب المعادلات للأسفل كما تمت الإشارة إليه في المشاركة السابقة وذلك لأنني قمت بوضع المعادلة على الملف المرفق بقدر البيانات الموجودة سابقا فقط هناك كدالك نقطة مهمة يجب الإنتباه إليها في المعادلة المقترحة =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(D$2:D2)), "") وظيفتها إظهار الأرقام المفقودة من تسلسل يبدأ من 1 حتى أكبر رقم موجود في العمود A وتعرض النتيجة في العمود D أو B حسب وضعها كما جاء في طلبك لكن هذه الصيغة تفترض أن الأرقام تبدأ من 1 وتتزايد بواحد مثال عندما تكون الأرقام بهذا الشكل مثلا فالصيغة أعلاه لن تعمل كما يجب لأنها تبدأ بالبحث من الرقم 1 بينما الأرقام الفعلية تبدأ من 15 لحل هذا الإشكال نقترح استخدام الصيغة التالية التي تعتمد على أصغر وأكبر رقم موجودين فعليا في العمود A =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "") المعادلة تبحث عن جميع الأرقام بين MIN و MAX وتستبعد الأرقام الموجودة فعليا في العمود A أي ترجع فقط الأرقام المفقودة في تسلسل منتظم وتعرض النتائج بشكل ديناميكي في العمود D بدءا من D2 ارقام مفقودة 3.xlsb

بأبسط الامكانيات عملت لك حقلين في الأستعلام من نوع (True / False ) الأول يتحقق من دخول الفترة الزمنية نطاق التنفيذ .. والثاني يتحقق من أن الأيام دخلت نطاق التنفيذ .. وبالتالي صار سهل جدا فلترة السجلات بناءا عليهما : وهكذا تضع الشروط بكل سهولة 🙂 : Database1 (1).accdb

إليك أخي الملف كما طلبت مع تلوين الخلايا حسب الاختيار تسجيل بيانات2.xlsm

نعم ممكن , جرب هذا جدول 3.xlsx

تقبل الله طاعاتكم ، وبارك الله بكم ، ونفع بكم أخي الفاضل @algammal .. لهو شرف لي مشاركتك اسمي بين نخبة من معلمي و أساتذة هذا الصرح الكبير في هذا القسم الرائع ، وقد أسعدتَ قلبي بكلماتك الطيبة والتي إن نبعت ، فهي نابعةٌ من جمال وطيب قلبك وأصلك وخُلُقك . وكما أسلف اساتذتنا هنا سابقاً ، نحن هنا نساند بعضنا البعض بمودة ومحبة بما علمنا الله من علمه - ولا علم إلا علمه - ولله الفضل من قبل ومن بعد . وبإسمي وبإسم قسم الآكسس عموماً ، نسأل الله أن يتقبل طاعاتكم ، ونتمنى لكم عيد أضحى مبارك 🐑.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("الاختلافات"): End Property Sub Button1_Click() Dim i As Long SetApp False For i = 3 To 62 WS.Rows(i).Hidden = (Application.WorksheetFunction.CountA(WS.Range("B" & i & ":R" & i)) = 0) Next i SetApp True End Sub Sub Button49_Click(): SetApp False: WS.Rows("3:62").Hidden = False: SetApp True: End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub كود إخفاء وإظهار.xlsb

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

السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm

ما شاء الله ، تبارك الله .. أفكار وحلول جميلة ، من الأساتذة ( @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 وصورة توضيحية للنتيجة

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

بسيطة أخي الكريم ، الآن حسب ملفك المرفق ، جرب هذا التعديل :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long, colNum As Long Dim targetCell As Range On Error GoTo SafeExit Set chk = ActiveSheet.CheckBoxes(Application.Caller) If chk.TopLeftCell Is Nothing Then GoTo SafeExit Set rng = chk.TopLeftCell rowNum = rng.Row colNum = rng.Column Set targetCell = Cells(rowNum, colNum - 1) ' عدّل هنا : لتحديث الخلية اليمين = + 1 If chk.Value = xlOn Then If IsEmpty(targetCell.Value) Then targetCell.Value = Now End If ElseIf chk.Value = xlOff Then targetCell.ClearContents End If SafeExit: End Sub والتأكد من عدم وجود عناصر متشابهة في الإسم من الـ CheckBox ، وقم باستدعاء الماكرو لكل عنصر منهم .. * ملاحظة ، تستطيع التبديل بين الخلية اليمين أو اليسار التي سيتم عرض التاريخ و والوقت فيها على الملف كاملاً من خلال استبدال -1 بـ +1 فقط ، كما هو موضح في الكود . 222مربع اختيار يضيف التاريخ والوقت عند الاختيار.zip

هلا والله ... والله اشتقنا للأسف انا لم أكن اعرف المطلوب وضعت الإجابة بناء على السؤال حلوه النماذج الجميله اللى بتغير الوانها دى👍 بس فكرتى احلى 🤪 هو كده غلاسه 😆🫣

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

وعليكم السلام ورحمة الله وبركاته ,,, بعد عدة محاولات من خلال المعادلات ، وجدت أنه من الصعب عدم تحديث الخلايا الغير معنية بالإدراج ، لذا توجهت الى استخدام الماكرو التالي :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long For Each chk In ActiveSheet.CheckBoxes Set rng = chk.TopLeftCell rowNum = rng.Row If chk.Value = xlOn Then If IsEmpty(Cells(rowNum, "A").Value) Then Cells(rowNum, "A").Value = Now End If ElseIf chk.Value = xlOff Then Cells(rowNum, "A").ClearContents End If Next chk End Sub وعليه ، فيتم استدعائه في جميع الـ CheckBoxes التي لديك فقط ، دون ربط العناصر ببعضها .. ملفك بعد التعديل ، جرب وأخبرنا بالنتيجة مربع اختيار يضيف التاريخ والوقت عند الاختيار.zip

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم في هذا الموضوع أداة بسيطة وفعالة قمت بتطويرها لأغراض إنشاء واستعادة نسخ احتياطية من قواعد بيانات اكسيس . ✔️ الهدف الأساسي من الأداة هو توفير طريقة مرنة وآمنة لأخذ نسخ احتياطية من الجداول المهمة بشكل دوري أو عند الحاجة ، وتسهيل استعادتها لاحقاً بنفس البنية والبيانات . صورة من واجهة الأداة :- الواضح من الواجهة ، أن الأداة ستمكنك من :- أولاً :- إنشاء نسخة احتياطية ضمن الإعدادات التي تحددها في زر "خيارات الحفظ" . عند النقر عليه ستجد هذه الإعدادات في الصورة .. مسار الحفظ للنسخ الإحتياطية سيكون فقط في المجلد Backup في المجلد الرئيسي Data الموجود بجانب قاعدة البيانات . نوع الملحق سيكون MDB و DAT . وهما النوعين الأكثر شمولاً واستخداماً في جميع الأفكار التي لها نفس الوظيفة . عدد النسخ التي ستحتفظ بها هو فقط ما تحدده . وسيتم حذف النسخ الأقدم تباعاً . بإمكانك تحديد كلمة مرور لحماية قاعدة بيانات الجداول . ولا ننصح بتغييرها لكل نسخة كي لا تتوه وتفقد بياناتك . إمكانية النسخ التلقائي حسب عدد الأيام أو الساعات الي تريد أخذ نسخة تلقائية فيه . ثانياً :- إنشاء نسخة احتياطية لجداول تقوم بتحديدها - ولك حرية اختيار الجداول في كل نسخة - حيث أنها لن تؤثر على سير عملية الإسترجاع لاحقاً . انظر الصورة للتوضيح :- على اليمين تظهر أسماء الجداول في القاعدة الحالية ( مرتبطة أو محلية ) . ولك الحرية باختيار جداول محددة بالنقر المزدوج على الجدول ، أو تحديد الكل / إلغاء الكل . حسب حاجتك . ثالثاً :- الأزرار كما هي في صورة واجهة الأداة ، تشير إلى :- زر "حفظ نسخة إحتياطية جديدة" :- لإنشاء نسخة إحتياطية حسب الإعدادات اتي تم تحديدها . زر "تحديث بيانات النُسخ الإحتياطية" :- لإعادة ترتيب السجلات في الجدول حسب النسخ الموجودة في مجلد انسخ الإحتياطي . زرا "نُسخ محددة" و "كافة النُسخ" :- لحذف محدد أو لجميع النسخ الإحتياطية . زر "إنشاء" في قسم "نسخة خاصة" :- مخصص لإنشاء نسخة خاصة في مكان يقوم المستخدم بتحديده وليس ضمن المسار المحدد في الإعدادات ، وبإسم متغير كيفما يريد . زر "استرجاع" في قسم "نسخة خاصة" :- مخصص لإسترجاع نسخة يقوم المستخدم بتحديدها بشكل يدوي من خلال مربع حوار اختيار ملف . زر "استرجاع" في قسم "استرجاع النسخة رقم" :- مخصص لاختيار نسخة محددة برقمها . حيث تظهر النسخ التي تم أخذها إحتياطياً ، في أعلى جزء النموذج والتنقل بينها من خلال الزرين < > . رابعاً :- في هذا الإصدار ( V1.0 ) من الأداة على عدم الإعتماد على أي مكتبات خارجية أو من مكتبات أكسيس . حيث تمت التجربة على إصدارات اكسيس ( 2010 فما فوق ) . Backup 2025 - V1.0.accdb.zip :- دائماً يسعدني إبدائكم الرأي والملاحظات حول الأخطاء والمشاكل التي يمكن مواجهتها في أي مشروع يتم تأسيسه في آكسيس أو غيره من لغات البرمجة . أولاً تأكد من وجود جدولي الأداة ( USysMyCopies و USysOptCopies ) عند نسخها الى مشروعك . مع العلم أنها مخفية كجداول نظام ، ويمكنك إظهارها كما في الصورة التالية :- ثانياً ، قم بالدخول الى خيارات الحفظ ، والنقر على زر "انقر لضبط مسار مجلد الحفظ بشكل آلي" لضبط وتحديد مسار مجلد الحفظ الرئيسي . فقط لأول مرة .

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit 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 ترحيل v2.rar

وعليكم السلام ورحمة الله وبركاته استكمالا لما تفضل به الأساتذة @Foksh و @hegazee من حلول مشكورة و إثراءا للموضوع أضع بين يديك اقتراحا إضافيا ربما قد يكون مناسبا لطلبك Private Sub Worksheet_Change(ByVal Target As Range) Const ColF As Long = 5, Irow As Long = 2, Max As Long = 5 Dim rng As Range, i As Long, ky() As String, Cnt$, tmp$, msg$, txt$ If Target.Column = ColF Then On Error GoTo Cleanup SetApp False For Each rng In Target txt = Trim(CStr(rng.Value)): msg = "" If txt = "" Then GoTo NextCell If InStr(txt, "/") > 0 Then msg = "(/) " & _ "خطأ: يرجى استخدام الشرطة العادية (-) بدلا من الشرطة المائلة" If msg = "" And InStr(txt, "-") = 0 Then msg = "خطأ: التنسيق غير صحيح" If msg = "" Then ky = Split(txt, "-") If UBound(ky) <> 1 Then msg = "خطأ: يجب أن يكون التنسيق بالشكل (رقم-رموز)" Else Cnt = ky(0): tmp = ky(1) If msg = "" And (Not IsNumeric(Cnt) Or Len(Cnt) < 1 Or Len(Cnt) > Irow) Then _ msg = "خطأ: الجزء الأول يجب أن يكون رقمًا مكونا من رقم أو رقمين فقط" If msg = "" And Len(tmp) > Max Then msg = "خطأ: الحد الأقصى للرموز بعد الشرطة هو 5 رموز" If msg = "" And Left(tmp, 1) = "0" Then msg = "خطأ: لا يسمح ببدء الجزء الثاني بصفر" For i = 1 To Len(tmp) - 1 If msg = "" And Mid(tmp, i, 1) Like "[A-Za-z]" And Mid(tmp, i + 1, 1) = "0" Then msg = "خطأ: لا يسمح بوجود صفر بعد الحرف الإنجليزي": Exit For End If Next i End If End If If msg <> "" Then MsgBox msg, vbCritical, "خطأ في إدخال رقم الحالة": rng.Value = "" NextCell: Next rng End If Cleanup: SetApp True 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 Book1 v2.xlsm

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @hegazee :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, val As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^\d{1,2}-([a-zA-Z][1-9]\d*|[1-9]\d*[a-zA-Z]?)$" For Each c In Intersect(Target, Columns("E")) If Not IsEmpty(c) Then val = c.Value If Not regex.Test(val) Or Len(val) > 8 Then MsgBox "صيغة غير صحيحة! يجب أن تكون:" & vbCrLf & vbCrLf & _ "تستخدم شرطة (-) فقط (.1)" & vbCrLf & _ "لا تبدأ الأرقام بصفر (.2)" & vbCrLf & _ "لا يوجد صفر بعد الحرف الإنجليزي (.3)" & vbCrLf & _ "(12-a1234 :مثال ) الحد الأقصى 8 أحرف (.4)", _ vbExclamation + vbMsgBoxRight, "تصحيح" Application.Undo End If End If Next c End Sub جربها وأخبرنا بالنتيجة ..

أخي @Hesham.Abusna نرجو منك التكرم بإرفاق نسخة من الملف الذي واجهت فيه المشكلة هدا سيساعدنا ذلك كثيرا على فحص هيكل الملف و المعادلات المستخدمة ولربما حجم البيانات ومن ثم تقديم الحل الأمثل بإذن الله كما يجب الإنتباه أنه في بعض الحالات قد يتسبب حجم المعادلات الكبير أو وجود أكواد معقدة أو حتى أوراق فارغة أو مخفية في اختلاف سلوك الكود لذلك فالمعاينة المباشرة ضرورية لتقديم دعم دقيق ومناسب و تشخيص المشكلة بدقة والوقوف على السبب الفعلي على العموم جرب الكود التالي على ملفك الأصلي ووافينا بالنتيجة Option Explicit Sub Sauvegarde_WB() Dim dossier$, chemin$, sFichier$, sPath$, sNom$ Dim WS As Worksheet, newWB As Workbook, newWs As Worksheet Dim n As Integer, data As Variant, OnRng As Range, _ shp As Shape, col As Long, rw As Long On Error GoTo EndClear SetApp False Set newWB = Workbooks.Add(xlWBATWorksheet) newWB.Sheets(1).Name = "Temp" n = 1 For Each WS In ThisWorkbook.Worksheets Set newWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count)) sNom = Left(WS.Name, 31) Do While f(sNom, newWB) sNom = Left(WS.Name, 28) & "_" & n: n = n + 1 Loop newWs.Name = sNom Set OnRng = WS.UsedRange If OnRng.Cells.Count > 1 Then data = OnRng.Value newWs.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data OnRng.Copy newWs.Range("A1").PasteSpecial xlPasteFormats Application.CutCopyMode = False For col = 1 To OnRng.Columns.Count newWs.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth Next col For rw = 1 To OnRng.Rows.Count newWs.Rows(rw).RowHeight = WS.Rows(rw).RowHeight Next rw Application.Goto newWs.Range("A1"), True End If On Error Resume Next For Each shp In newWs.Shapes If shp.Type = msoFormControl Or shp.Type = msoOLEControlObject Then shp.Delete Next shp On Error GoTo EndClear Next WS newWB.Sheets("Temp").Delete dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sFichier = sPath & "_" & Format(Now, "dd-mm-yyyy_hh-nn-ss") & ".xlsx" chemin = dossier & "\" & sFichier newWB.Sheets(1).Activate newWB.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook newWB.Close False MsgBox "تم نسخ الملفات بنجاح", vbInformation SetApp True Exit Sub EndClear: SetApp True 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 Private Function f(sheetName As String, wb As Workbook) As Boolean Dim sht As Worksheet For Each sht In wb.Sheets If sht.Name = sheetName Then f = True: Exit Function Next sht f = False End Function إليك المرفق مرة أخرى بعد إظافة بعض المعادلات الجديدة للتجربة TEST v2.rar

انا بقي بعد اكثر من سنه ونصف او اكثر شوي على وندوز 11 رجعت ل 10 علشان وحشني 😁 (وعلشان حسيت وندوز 11 بدأ يتغابي معايا ولقيت نفسي باعاني معاه فقولت الطلاق افضل ورجعت لام عيالى وندوز 10) ^_^

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل أخي الكريم رصيد بنــــك الكويت.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arrays3() Dim lr&, LR2&, WSData As Worksheet Dim Dest As Worksheet: Set Dest = Sheets("class_room") LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row If LR2 >= 2 Then Dest.Range("B2:S" & LR2).ClearContents Application.ScreenUpdating = False For Each WSData In Sheets(Array("كي جي1", "كي جي2", _ "الصف الأول", "الصف الثاني", "الصف الثالث", "الصف الرابع", "الصف الخامس", "الصف السادس")) lr = WSData.Cells(WSData.Rows.Count, "B").End(xlUp).Row If lr >= 3 Then LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row + 1 Dest.Range("B" & LR2 & ":S" & (LR2 + lr - 3)).Value = WSData.Range("B3:S" & lr).Value End If Next WSData Application.ScreenUpdating = True MsgBox "تم ترحيل الفرق بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته هناك عدة حلول تعتمد على طريقة عملك منها استخدام USERPROFILE لجعل مسار الملف ديناميكيا _ وضع المصنف في نفس مجلد ملف الماكرو أو السماح للمستخدم باختيار الملف يدويا (Browse) كما أشار الأخ الفاضل @hegazee اليك الأكواد بالترتيب المدكور يمكنك إختيار ما يناسبك Sub OpenWorkbook1() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Environ("USERPROFILE") & "\Desktop\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '=================================================== Sub OpenWorkbook2() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = ThisWorkbook.Path & "\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox " :الملف غير موجود" & vbNewLine & vbNewLine & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '================================================== Sub OpenWorkbook3() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then MsgBox "تم إلغاء العملية", vbInformation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح: " & xPath, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub وفي حالة الرغبة في التحقق من أن إسم الملف الذي يختاره المستخدم يطابق إسم معين مثلا aa.xlsb قبل فتح الملف Sub OpenWorkbook4() Dim xPath$, CrWS As Workbook,Sname$ On Error GoTo ErrHandler Sname = "aa.xlsb" xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then: MsgBox "تم إلغاء العملية", vbInformation: Exit Sub fileName = Dir(xPath) If StrComp(fileName, Sname, vbTextCompare) <> 0 Then MsgBox "اسم الملف غير مطابق" & vbNewLine & Sname, vbCritical Exit Sub End If Set CrWS = Workbooks.Open(xPath) MsgBox " :تم فتح الملف بنجاح" & vbNewLine & vbNewLine & CrWS.name, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub bb.xlsb

عندي ملف من إعداد الاستاذ مصطفى شرف و قمت بالتعديل عليه الشرح للأستاذ مصطفى من هنا توزيع الملاحظين 2024.xlsm

السلام عليكم ورحمة الله وبركاته كثيرا ما حاولت فتح التقرير وعرضه بالتبديل من الوضع العمودي الى الوضع الأفقي خاصة عندما افتحه مخفيا على عرض التصميم للتعامل مع الحقول برمجيا وكانت النتيجة انه يمكن التعامل برمجيا مع الحقول .. وإنشاء حقول جديدة .. ويمكنني بعد ذلك عرضه للمعاينة بحقوله الجديدة ولكن استعصى علي التبديل في العرض من عمودي الى افقي والعكس .. وبعد التمعن والمحاولة عرفت السبب .. واذا عرف السبب بطل العجب وهو اني احاول التعامل مع التقرير من خلال خصائصه .. وخصائص التقرير لا تدعم هذه الميزة ثم تنبهت الى ان هذه الميزة وخصائص الهوامش وعرض الأعمدة والمسافات بين الاعمدة وغيرها يتم التحكم بها من خلال خصائص طباعة التقرير لن اطيل عليكم فبالمثال يتحقق المقال : 'للعرض الأفق DoCmd.OpenReport "Report1", acViewPreview Reports!Report1.Printer.Orientation = acPRORLandscape 'للعرض الرأسي DoCmd.OpenReport "Report1", acViewPreview Reports!Report1.Printer.Orientation = acPRORPortrait وهذه الطريقة الشاملة للتعامل Private Sub Command2_Click() ' او افتح تقريرك على التصميم وتعامل مع الحقول DoCmd.OpenReport "Report1", acViewDesign, , , acHidden 'اكتب هنا اكوادك الخاصة بالتعامل مع الحقول او العناصر الأخرى '............ '............ '............... ' ثم اختر طريقة العرض الرأسي Reports!Report1.Printer.Orientation = acPRORPortrait ' أو الأفقي 'Reports!Report1.Printer.Orientation = acPRORLandscape ' افتح التقرير للمعاينة DoCmd.OpenReport "Report1", acViewPreview End Sub فتح التقرير افقي او عمودي برمجيا.rar

و عليكم السلام ورحمة الله و بركاته تحياتي للأستاذ @Foksh الألوان تستخدم في كنترول الابتدائي و ذلك لعدم وجود طابعات ألوان فيتم كنتابة اللون . لذلك هناك حل بسيط بالمعادلات حيث يتم لصق المعادلة التالية في الخلية M7 ثم سحبها للأسفل: =IFS(I9>=85;"أزرق"; I9>=65;"أخضر"; I9>=50;"أصفر"; TRUE;"أحمر")

وعليكم السلام ورحمة الله وبركاته ,, بداية أود أن أوضح لك أنه لا يمكن لأكسل التعرف على اسم اللون كما في طلبك ، ولكن يمكننا التحايل عليه بفكرة إلتفافية حول الموضوع ، حيث أولاً يمكن استخراج رقم ( كود ) اللون ، وبذلك أولاً سنستخدم دالة بسيطة تساعدنا في هذه المهمة كالآتي :- Function GetColorCode(rng As Range) As Long GetColorCode = rng.Interior.Color End Function الآن بعد أن حصلنا على النتيجة ، سنستخدم دالة تقوم بالتعرف على اللون الناتج من الدالة السابقة ومحاولة تقريبه الى أقرب درجة معروفة سنقوم بإدخال قيمها يدوياً داخل الدالة ، كالآتي :- Function GetApproximateColorName(rng As Range) As String Dim colorCode As Long, R As Integer, G As Integer, B As Integer colorCode = rng.Interior.Color R = colorCode Mod 256 G = (colorCode \ 256) Mod 256 B = (colorCode \ 65536) Mod 256 If R > 200 And G < 50 And B < 50 Then GetApproximateColorName = "أحمر" ElseIf R > 200 And G > 200 And B < 100 Then GetApproximateColorName = "أصفر" ElseIf R > G And R > B Then GetApproximateColorName = "أحمر" ElseIf G > R And G > B Then GetApproximateColorName = "أخضر" ElseIf B > R And B > G Then GetApproximateColorName = "أزرق" ElseIf R = G And G = B Then GetApproximateColorName = IIf(R < 128, "غامق", "فاتح") & " رمادي" Else GetApproximateColorName = "لون مختلط" End If End Function طبعاً قمت بتغيير الألوان في مثالك إلى الألوان الصريحة لكل لون ( الأخضر ، الأزرق ، الأصفر ، الأحمر ) . وبهذا ، سيتم الاستدعاء في الخلية التي تريد إدراج اسم اللون فيها بهذا الشكل :- =GetApproximateColorName(K7) طبعاً فقط ضع هذا الكود في الخلية L7 ثم اسحب تحديد الخلية الى باقي الخلايا لتطبيق الكود عليها جميعاً . وهذا ملفك بعد التعديل :- Book2.xlsm

وعليكم السلام ورحمة الله وبركاته ، في البداية أعتقد أن الفكرة قد تكون متشعبة نوعاً ما ، بالإعتماد على النتائج التي قد تحتلف في كل مرة يتم فيها النقر على زر "توزيع الملاحظين" . لذا بعد تجربتك لهذه الفكرة البسيطة ، أخبرنا بالنتيجة وبالتفصيل . مع العلم أنه يوجد لديك فكرتين ، ومن خلال تجربتك ومتابعتك للنتائج ، اخبرنا بتفاصيل النتائج التي عادت لك . شرح الفكرة الأولى التي تمت :- السرعة في التوزيع ، حيث يعمل الكود بشكل أسرع بكثير لأنه :- يستخدم مصفوفات للتعامل مع البيانات بدلاً من الخلايا مباشرة . يعطل التحديث التلقائي وإعادة الحساب أثناء التنفيذ . ضمان عدم تكرار الملاحظ في نفس اللجنة :- يستخدم خوارزمية توزيع دائرية تضمن عدم التكرار في اللجنة الواحدة . التوزيع العادل :- يحاول توزيع الملاحظين على اللجان بالتساوي قدر الإمكان . يمر كل ملاحظ على جميع اللجان خلال فترات الامتحانات . الكود الذي تم استخدامه لهذه الفكرة ( مع دالة بسيطة مساعدة ) :- Sub DistributeObservers() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("الثانوية العامة") Dim observers As Range, committees As Range Dim observerCount As Long, committeeCount As Long Dim distributionRange As Range Dim i As Long, j As Long, attempts As Long Dim observerList() As Variant, committeeList() As Variant Dim distributionArray() As Variant Dim observerUsage() As Long Set observers = ws.Range("B3:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).row) observerCount = observers.Count observerList = observers.Value committeeCount = 30 ReDim committeeList(1 To committeeCount) For i = 1 To committeeCount committeeList(i) = "لجنة " & i Next i Set distributionRange = ws.Range("D3").Resize(observerCount, committeeCount) ReDim distributionArray(1 To observerCount, 1 To committeeCount) ReDim observerUsage(1 To observerCount) Dim randomizedObservers() As Variant randomizedObservers = ShuffleArray(observerList) For j = 1 To committeeCount For i = 1 To observerCount distributionArray(i, j) = randomizedObservers((i + j - 2) Mod observerCount + 1, 1) observerUsage((i + j - 2) Mod observerCount + 1) = observerUsage((i + j - 2) Mod observerCount + 1) + 1 Next i Next j distributionRange.Value = distributionArray For i = 1 To observerCount ws.Cells(i + 2, 1).Value = Application.CountIf(distributionRange, observerList(i, 1)) Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم التوزيع بنجاح!", vbInformation + vbMsgBoxRight, "" Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub Function ShuffleArray(arr As Variant) As Variant Dim i As Long, j As Long Dim temp As Variant For i = UBound(arr) To LBound(arr) + 1 Step -1 j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr)) temp = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = temp Next i ShuffleArray = arr End Function شرح الفكرة الثانية التي تمت :- بالذهاب الى التخلص من الدوال المساعدة ، أو تقييد الفكرة السابقة ، حيث تم استنباط فكرة أخرى تعمل على :- استخدام خوارزمية توزيع دائرية مباشرة بدون حاجة لفكرة خلط المصفوفات التي قد تكون ذات نتائج مختلفة في كل مرة عند التوزيع . ( وهي الفكرة التي خطرت ببالي سابقاً ) . الإعتماد على احتساب التكرارات أثناء التوزيع نفسه . معالجة البيانات كمصفوفات بدلاً من نطاقات خلايا !!!!! تقليل الوصول إلى ورقة العمل ، مما يساعد على الوصول الى نتيجة أسرع . اعتماد فكرة رسائل أكثر وصفية و تحتوي على أرقام الملاحظين واللجان . الكود الذي تم استخدامه لهذه الفكرة :- Sub DistributeObservers() On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الثانوية العامة") Dim observers As Variant: observers = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Value Dim observerCount As Long: observerCount = UBound(observers) Dim committeeCount As Long: committeeCount = 30 ws.Range("A3:A" & observerCount + 2).ClearContents ws.Range("D3").Resize(observerCount, committeeCount).ClearContents Dim i As Long, j As Long For j = 1 To committeeCount For i = 1 To observerCount ws.Cells(i + 2, j + 3).Value = observers((i + j - 2) Mod observerCount + 1, 1) Next i Next j For i = 1 To observerCount ws.Cells(i + 2, 1).Value = Application.CountIf(ws.Range("D3").Resize(observerCount, committeeCount), observers(i, 1)) Next i MsgBox "تم توزيع " & observerCount & " ملاحظاً على " & committeeCount & " لجنة بنجاح", vbInformation + vbMsgBoxRight, "إنجاز" ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err.Number <> 0 Then MsgBox "خطأ " & Err.Number & ": " & Err.Description, vbCritical, "خطأ" End Sub وطبعاً في كلا الحالتين ، تم اضافة دالة ماكرو بسيطة لمسح القيم وتنظيف الجدول من التوزيعات :- Sub ClearDistribution() Application.ScreenUpdating = False On Error Resume Next Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("الثانوية العامة") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).row ws.Range("D3:AH" & lastRow).ClearContents ws.Range("A3:A" & lastRow).ClearContents Application.ScreenUpdating = True MsgBox "تم مسح بيانات التوزيع بنجاح", vbInformation + vbMsgBoxRight, "" End Sub الملفين للفكرتين :- ملاحظة_ث.ع - 1.xlsm ملاحظة_ث.ع - 2.xlsm

🌿 إلى صاحب الموضوع الكريم، صاحب الوفاء والعرفان @algammal: وعليكم السلام ورحمة الله وبركاته، لقد أكرمتنا بكلماتك النبيلة، وأغدقت علينا من جميل ثنائك، فكان لتهنئتك وقعٌ في القلب لا يخفى، ولحروفك أثرٌ في النفس لا يُمحى. جزاك الله خيرًا على هذا اللطف والكرم، وأسأل الله أن يبارك لك في علمك وعملك، وأن يجعل أيامك عامرةً بالسعادة والرضا. ✨ إلى الإخوة الزملاء الأفاضل، أهل الفضل والعطاء: إنه لمن دواعي الفخر أن نكون جزءًا من هذا الصرح العلمي المبارك، حيث تتلاقى العقول، وتتعانق الأفكار، ويُسهم كل منا بما استطاع في نشر العلم وإعانة السائلين. وما نحن إلا حلقةٌ في سلسلةٍ ممتدةٍ من العطاء، ننهل من معين من سبقونا، ونستنير بهديهم. أسأل الله أن يجعل هذا المنتدى المبارك منارةً للعلم، وموئلًا للباحثين، وأن يبارك في جهود الجميع، ويجزيكم خير الجزاء على كلماتكم الطيبة التي زادتنا شرفًا وسرورًا. 🌍 إلى جميع الإخوة الأعضاء الكرام: كل عام وأنتم بخير، أعاده الله علينا وعليكم وعلى الأمة الإسلامية بالخير واليمن والبركات، وجعل أيامكم عامرةً بالمسرات، وأفئدتكم مطمئنةً بالرضا والسعادة. نسأل الله أن يديم علينا نعمة الأخوة، وأن يبارك في هذا الجمع الطيب، وأن يجعل العلم الذي نتشاركه نورًا لنا في الدنيا والآخرة. 🔹 أخوكم / محمد صالح

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

أخي الفاضل المحترم الكريم زادك الله من علمه كل عام وانت طيب وبخير وبصحة جيدة وفي أحسن حال أخي المبجل ( foksh )

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM تم تعديل الكود حسب طلبك ليعرض عمودين في ListBox داخل نموذج البحث مثلا (الإسم + التسلسل) يمكنك تعديله بما يناسبك وقد قمت بمحاولة تنقيحه وتحسينه ليكون أكثر كفاءة وتنظيما يرجى أولا تفريغ جميع الأكواد السابقة من النموذج ثم نسخ الكود التالي بالكامل Option Explicit Private ColArr As Variant Public Property Get WS() As Worksheet: Set WS = Sheets("add"): End Property Public Property Get dest() As Worksheet: Set dest = Sheets("search"): End Property Private Sub UserForm_Initialize() TextBox1.SetFocus 'قم بتحديد الأعمدة المرغوب عرضها ColArr = Array(2, 1) ' 2 = الإسم / 1 = التسلسل With ListBox1: .ColumnCount = UBound(ColArr) + 1: .ColumnWidths = "100pt;40pt": End With End Sub Private Sub TextBox1_Change() Dim c As Range, tmp As String, lastRow As Long, i As Long, listCount As Long ListBox1.Clear If IsEmpty(ColArr) Then Exit Sub tmp = Trim(TextBox1.Value) If Len(tmp) = 0 Then Exit Sub SetApp False lastRow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row For Each c In WS.Range(WS.Cells(5, ColArr(0)), WS.Cells(lastRow, ColArr(0))) If InStr(1, c.Value, tmp, vbTextCompare) > 0 Then ListBox1.AddItem c.Value listCount = ListBox1.listCount For i = 1 To UBound(ColArr) ListBox1.List(listCount - 1, i) = c.EntireRow.Cells(1, ColArr(i)).Value Next i End If Next c SetApp True End Sub Private Sub CommandButton1_Click() Dim Irow As Long, f As Long, i As Long, xName As String, cnt As Boolean: cnt = False If ListBox1.listCount = 0 Then MsgBox "لا توجد نتائج للبحث", vbExclamation, "تنبيه": Exit Sub xName = Trim(TextBox1.Value): Irow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row SetApp False For i = 5 To Irow If WS.Cells(i, ColArr(0)).Value = xName Then If Not cnt Then dest.Range("A8:L" & dest.Rows.Count).ClearContents f = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 dest.Range("A" & f).Resize(1, 12).Value = WS.Cells(i, 2).Resize(1, 12).Value cnt = True End If Next i If Not cnt Then MsgBox "لم يتم العثور على الاسم" & xName & " ضمن كشف المرحليات", vbInformation, "نتيجة البحث" SetApp True: Unload Me End Sub Private Sub ListBox1_Click() TextBox1.Value = ListBox1.List(ListBox1.ListIndex, 0) End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub المرحليات أوفيسنا v2.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