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

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

طيب كفكرة ممكن تعمل الساعة لحالها في نموذج فرعي وتعمل الحدث في النموذج الفرعي بدون ما يأثر على أحداث النموذج الرئيسي 🙂 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 وصورة توضيحية للنتيجة

في بيئات العمل الحديثة التي تعتمد على الشبكات المحلية، يُعد الاتصال المستقر بقاعدة البيانات الخلفية أمرًا أساسيًا لاستمرارية العمليات اليومية. ومع ذلك، تظهر أحيانًا مشكلات تقنية تتعلق بفقدان بيانات الاعتماد (اسم المستخدم وكلمة المرور) الخاصة بالوصول إلى مجلدات شبكية تحتوي على قاعدة البيانات ويتم الاتصال بالشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB. تخيل هذا السيناريو: · جهاز جديد ينضم إلى الشبكة. · أحد الأجهزة يتعرض لعطل مفاجئ، أو يتم إعادة تشغيله رغم تفعيل خيار "تذكر بيانات الاعتماد"، يفقد النظام هذه البيانات بعد التشغيل، مما يؤدي إلى انقطاع الاتصال بقاعدة البيانات وتعطل سير العمل. الحل: أداة متقدمة لإدارة بيانات الاعتماد تم تطوير كود ذكي لمعالجة هذه المشكلة بفعالية وكفاءة، من خلال : تخزين بيانات الاتصال (العنوان - اسم المستخدم - كلمة المرور) داخل نظام Windows Credential Manager المدمج في نظام التشغيل. أبرز المميزات: · سهولة الاستخدام: وظائف جاهزة لإضافة، وحذف بيانات الاعتماد بضغطة واحدة، دون الحاجة لأي معرفة برمجية. · ثبات الاتصال: يتم حفظ بيانات الاعتماد بشكل دائم حتى بعد إعادة تشغيل الجهاز، مما يضمن استمرارية الاتصال بقواعد البيانات دون الحاجة لإعادة الإدخال يدويًا. · توافق واسع: متوافق مع أنظمة Windows وOffice بنواتيها 32-بت و64-بت، ما يضمن عمله في مختلف بيئات العمل بدون مشاكل توافق. فوائد الكود: · توفير الوقت بإلغاء الحاجة إلى إدخال بيانات الاعتماد بشكل متكرر. · ضمان اتصال دائم وموثوق مع الشبكة وقواعد البيانات. · إمكانية التخصيص ليتناسب مع احتياجات كل مستخدم أو مؤسسة. · مناسب لجميع المستخدمين سواء المبتدئين أو المحترفين. الخاتمة: لا تدع مشكلات الشبكة تعرقل سير العمل. باستخدام هذه الأداة، يمكنك إدارة بيانات الاعتماد بكل كفاءة وأمان، مما يضمن اتصالًا ثابتًا ومستقرًا بقاعدة بياناتك في جميع الأوقات. إنها الحل المثالي لتطبيقات الشبكات المحلية التي تعتمد على الاتصال المستمر والسلس بقواعد البيانات. صور توضح مكان حفظ أو جلب بيانات الاعتماد من النظام: للتأكيد هنا نتعامل مع Windows Credentials وذلك لادارة بيانات اعتماد خاصة بتسجيل الدخول في نطاق (Domain) خاص بـ Windows مثل كلمات المرور المستخدمة لتسجيل الدخول إلى الشبكات أو الأجهزة عبر البروتوكولات مثل RDP أو SMB الكود الخاص بإدارة البيانات ( إضافة / حذف ) سوف نضع وحده نمطية باسم : basCredentialsmanager Option Compare Database Option Explicit '=========================== ' إضافة بيانات Credential '=========================== Public Function AddWindowsCredential(ByVal strTarget As String, ByVal strUserName As String, ByVal strPassword As String) As Boolean Dim strCommand As String Dim lngExitCode As Long strCommand = "cmd.exe /c cmdkey /add:" & strTarget & " /user:""" & strUserName & """ /pass:""" & strPassword & """ && exit 0 || exit 1" lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True) AddWindowsCredential = (lngExitCode = 0) End Function '=========================== ' حذف بيانات Credential '=========================== Public Function DeleteWindowsCredential(ByVal strTarget As String) As Boolean Dim strCommand As String Dim lngExitCode As Long strCommand = "cmd.exe /c cmdkey /delete:""" & strTarget & """ && exit 0 || exit 1" lngExitCode = ExecuteAndWait(strCommand, WindowHidden, True) DeleteWindowsCredential = (lngExitCode = 0) End Function ' وظيفة للتحقق من أن السلسلة غير فارغة وخالية من محرف Null Public Function ValidateString(strInput As String) As Boolean ' أولاً، تحقق من أن السلسلة ليست فارغة بعد إزالة المسافات الزائدة ValidateString = Len(Trim(strInput)) > 0 ' إذا كانت السلسلة ليست فارغة، تحقق من عدم وجود محرف Null (vbNullChar) If ValidateString Then ValidateString = InStr(strInput, vbNullChar) = 0 End If End Function ' ==================================================== ' أمثلة لدوال اختبار الكود ' ==================================================== ' ==================================================== ' إضافة بيانات اعتماد (اسم مستخدم وكلمة مرور) ' ==================================================== Public Sub TestAddWindowsCredential() Dim strNetworkAddress As String Dim strNetworkUserName As String Dim strNetworkPassword As String Dim blnSuccess As Boolean ' بيانات اعتماد تجريبية strNetworkAddress = "TestTarget0123" strNetworkUserName = "TestUser0123" strNetworkPassword = "TestPass0123" ' استدعاء دالة الإضافة blnSuccess = AddWindowsCredential(strNetworkAddress, strNetworkUserName, strNetworkPassword) ' عرض النتيجة If blnSuccess Then MsgBox "تمت إضافة بيانات الاعتماد بنجاح.", vbInformation, "نجاح" Else MsgBox "تعذر إضافة بيانات الاعتماد.", vbInformation, "تنبيــه" End If End Sub ' ==================================================== ' حذف بيانات الاعتماد المخزنة ' ==================================================== Public Sub TestDeleteWindowsCredential() Dim strNetworkAddress As String Dim blnSuccess As Boolean ' العنوان الذي نريد حذف بياناته strNetworkAddress = "TestTarget0123" ' استدعاء دالة الحذف blnSuccess = DeleteWindowsCredential(strNetworkAddress) ' عرض النتيجة If blnSuccess Then MsgBox "تم حذف بيانات الاعتماد بنجاح.", vbInformation, "نجاح" Else MsgBox "تعذر حذف بيانات الاعتماد. تأكد من تسجيل الجهاز مسبقًا.", vbInformation, "تنبيــه" End If End Sub ولضمان التحكم الدقيق في إجراء العمليات وإرجاع النتائج سوف نعتمد على دالة : تعرف او شائعه لدى المطورين باسم : ShellWait وتم تناولها فى هذا الموضوع بالتفصيل لمن يريد العودة اليها إضافة وحدة نمطية عامة باسم : basShellExecutor الكود Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub وأخيرا المرفق ملاحظة: تم تعديل المرفق والموضوع بتاريخ : 02/06/2025 Credential Manager.accdb

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

بسيطة أخي الكريم ، الآن حسب ملفك المرفق ، جرب هذا التعديل :- 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) ^_^

وعليكم السلام ورحمة الله تعالى وبركاته 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

مشاركة بتوضيح فكرة الأستاذ @محمد هشام. مشكوراً على فكرته الجميلة .. 1. انسخ الدالة السابقة الى مديول جديد في مشروعك الرئيسي واحفظه . 2. تستطيع تشغيل الماكرو بالنقر على Alt + F8 ، ثم تختار اسم الماكرو ، وانقر زر تشيل Run . 3. سيتم إنشاء مجلد جديد حسب الكود ( Workbook_Copy ) . وبداخله نسخة من مشروعك الأصلي لا تحتوي معادلات أو أزرار أو أكواد ... الخ . 💡 والتوظيف الذكي في الكود ، أن النسخة الناتجة لا تدعم الماكرو حتى لو حاولت إعادة تضمينها ، انظر السطر :- xlOpenXMLWorkbook ' أي .xlsx أي أنه لم يستخدم فكرة استنساخ الملف الجديد عن الأصل بنفس الإمتداد . ودمتم بخير جميعاً

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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تعديل هدا بما يناسبك Option Explicit Sub Sauvegarde_WB() Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet Dim chemin$, sNom$, dossier$, sPath$, n As Boolean On Error GoTo EndClear SetApp False Set CrWS = Workbooks.Add(xlWBATWorksheet) Set f = CrWS.Sheets(1): f.Name = "Temp" n = True For Each WS In ThisWorkbook.Worksheets WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count) Set newWs = CrWS.Sheets(CrWS.Sheets.Count) newWs.UsedRange.Value = newWs.UsedRange.Value On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0 newWs.Name = Left(WS.Name, 31) If n Then: f.Delete: n = False Next WS dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx" chemin = dossier & "\" & sNom CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook CrWS.Close False 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 TEST.xlsb

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

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

أخي @algammal ربما ما لم تلاحظه هو أن القيم تعبأ على عناصر الكومبوبوكس مع تجاهل الفراغات والتكرارات ولهذا السبب تظهر معك مرة واحدة فقط وذلك لأن أرقام التسلسل الموجودة على ورقة معاشات هي نفسها الموجودة على الـ DATA ما يهمنا هنا هو جلب جميع البيانات المتوفرة على الورقتين التي تتضمن شروط التصفية المختارة وهذا واضح من خلال الإحصائيات أسفله وللتوضيح أكثر دعنا نجرب إضافة تسلسل جديد على ورقة المعاشات غير موجود مسبقا في DATA ونرى كيف سيتم التعامل معه لاحظ معي عند اختيار رقم التسلسل 1 الاحصائيات لدينا تظهر عدد الموظفين 2 على ورقة معاشات 1 وورقة DATA 1 أرفق لك آخر تحديث للملف توحيد البحث في شيت واحد v6.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الشهادات من " & _ début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf