Foksh

وإياكم مثلما دعيتم وأكثر في هذا اليوم الطيب .. العفو يا صديقي ..

تحسينات جديدة ، وإضافات جديدة في التحديث الجديد لجعل المشروع كاملاً متكاملاً

وإياكم أخي الكريم .. شكراً لك

عذراً على المداخلة ، لكني لم افهم الفكرة من تكرار الطلب مرتين 😅 أو ما الفرق بين الطلبين 😁 .

وعليكم السلام ورحمة الله وبركاته .. أخي الكريم أسعد ، محتاجين توضح لنا ما الذي قمت بتأسيسه وأين نجد تقريرك الذي تريد التعديل عليه ؟

وضحت الفكرة أخي الكريم ،، امهلني بعض الوقت للتفرغ من العمل . كما ارجو منك شرح طريقة تسجيل بيانات لمريض اواعطنا اسم مريض لديه تحاليل أخرى ، لأن تتبع طريقة العمل يأخذ وقتاً 🤗

وعليكم السلام ورحمة الله وبركاته ,, جرب هذا التعديل !! Sub imad() Dim doc As Document Dim db As Object Dim rs As Object Dim f As FileDialog Set doc = ActiveDocument Set db = CreateObject("DAO.DBEngine.120").OpenDatabase(ActiveDocument.Path & "\10 - TMLEK.mdb") Set rs = db.OpenRecordset("qtsder") Application.ScreenUpdating = False While Not rs.EOF With doc.Content.Find .ClearFormatting .Text = rs.Fields(0).Value .Replacement.ClearFormatting .Replacement.Text = rs.Fields(1).Value .Execute Replace:=wdReplaceAll, _ Format:=True, _ MatchCase:=True, _ MatchWholeWord:=True, _ Wrap:=wdFindContinue End With rs.MoveNext Wend rs.Close db.Close Set rs = Nothing Set db = Nothing Application.ScreenUpdating = True MsgBox "تم الانتهاء من الاستبدال بنجاح", vbInformation + vbMsgBoxRight, "" End Sub افتح الملف المرفق على اصدار 2016 ،واخبرنا بالنتيجة مجلد جديد (2).zip

كلامك سليم ومنطقي 100% 👍 ، الإعتماد على الدرجات في الخلايا لتحديد اللون فكرة أذكى وأدق ، وأنا فعلاً لم أتوجه الى هذا المنطلق بل حسب طلب الأخ في سؤاله 😅 وحتى يعمل السطر الذي تفضلتم به مع اصدارات اكسل 2010 ، هذا السطر بعد تعديله :- =IF(I9>=85,"أزرق",IF(I9>=65,"أخضر",IF(I9>=50,"أصفر","أحمر")))

اعتقد أنني اكتشفت أين يكمن الخلل . سأعدله قريباً بدلاً من الحيلة السخيفة السابقة

كلامك سليم 100% ، لاحظت ان هذه المشكلة ظهرت عندما جعلت الجدول الذي كان سابقاً غير مرتبط الى جدول مرتبط في قاعدة البيانات الخلفية . لذا كحل مؤقت ، سأقوم بتعديل المرفق في المشاركة على نحوه الجديد كحيلة مؤقتة .

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

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

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

مهندسنا الغالي ،، جاري المتابعة والتدقيق 😇 شكراً لمتابعتك بالإفادة الغير منقطعة

وعليكم السلام ورحمة الله وبركاته 🤗.. قد يكون إصدار الأوفيس لديك أو نسخة الويندوز بهما خلل ، فمن باب توسيع دائرة الإحتمالات أن تقوم باستبدال نسخة الأوفيس أولاً ..

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

النتيجة واحدة مؤكدة ، وفعلاً لا فرق بينهما في النتيجة .. مع العلم أن استخدامك للتجميع مباشرةً أفضل من ناحية الأداء مقارنة مع تضميني للشروط في استعلامي ، ( طبعاً التجميع في موضعه مناسب أكثر ،والسبب لعدم وجود دوال تجميع مثل "Sum" أو غيرها ) على سبيل المثال. أما فيما يتعلق بمثال الأخ @jo_2010 الأخير ، فهنا ويا حبذا منك أن تعيد صياغة المطلوب بشكل أوضح لخطوات المشكلة الثانية التي تواجهها . وليس فقط من خلال الصور التي ارسلتها . وإنما لخطوات العمل على مشروعك حتى تتبين لنا المشكلة بعينها .

وهذا ما كان معلمي الفاضل ابو خليل بانتظاره فعلاً .

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

كلامك يدل على أنك تحرص على أن يكون الحل مبني على أساس سليم وبعيد النظر وليس مرتبطاً بحالة واحدة ( كما هو في مثالنا هذا ) . وما نحن به في هذا القسم هو ليس إلا جزء من فيضكم الكريم وعلمكم الوفير .. لذا إن كان في فكرتي أخطاء مستقبلية - وهذا وارد 10000% - فهو يعتمد على ما تم تقديمه بين يدينا من أخونا @jo_2010 . ولكننا ننوه دائماً الى ضرورة التأسيس الصحيح ( وطبعاً يوجد الصحيح ويوجد الأصح منه ) .

مشاركة مع معلمي الفاضل @ابوخليل ، بعد وضوح الصورة من خلال الجدولين والفرق بينهما ، أنه يعرض السجلات دون الاعتماد على حقل مشترك بينهما ( من خلال الاستعلامين مصدري التقارير ) وهو الحقل PCode ،لذا ، قمت أولاً بالإستناد الى استعلام فرعي مساعد يجلب لي الـ PCode المشتركة بين الإستعلامين السابقين ، وقد اسميته qry_FilteredPCodeFromUrine :- SELECT DISTINCT tbl_NewResults.PCode FROM tbl_NewLab INNER JOIN tbl_NewResults ON tbl_NewLab.PCode = tbl_NewResults.PCode WHERE tbl_NewResults.Pus IS NOT NULL AND tbl_NewResults.RBCs IS NOT NULL AND tbl_NewResults.Epithelial IS NOT NULL AND tbl_NewLab.Period = No; وعدلت مصدر التقرير الرئيسي Y_N_Report ، ليصبح :- SELECT tbl_NewResults.PCode, tbl_NewLab.Pname, tbl_NewLab.Age, tbl_NewLab.DDate, tbl_NewResults.Creat, tbl_NewResults.GPT, tbl_NewResults.GOT, tbl_NewResults.Choles, tbl_NewResults.Trigly, tbl_NewResults.HDL, tbl_NewResults.LDL, tbl_NewResults.HDL_Risk, tbl_NewResults.[S-Colour], tbl_NewResults.Odour, tbl_NewResults.[S-Reaction], tbl_NewResults.Consistency, tbl_NewResults.Mucous, tbl_NewResults.Blood, tbl_NewResults.[S-Pus], tbl_NewResults.[S-RBCs], tbl_NewResults.Vegetable, tbl_NewResults.Starch, tbl_NewResults.Fat, tbl_NewResults.Cysts, tbl_NewResults.[S-Parasitic Ova], tbl_NewResults.[S-Others], tbl_NewResults.Volume, tbl_NewResults.Colour, tbl_NewResults.Aspect, tbl_NewResults.Reaction, tbl_NewResults.Sp_Gravity, tbl_NewResults.[U-Albumin], tbl_NewResults.Sugar, tbl_NewResults.Acetone, tbl_NewResults.Bilirubin, tbl_NewResults.Urobilin, tbl_NewResults.Pus, tbl_NewResults.RBCs, tbl_NewResults.Epithelial, tbl_NewResults.Casts, tbl_NewResults.Crystals, tbl_NewResults.Amourphous, tbl_NewResults.Ova, tbl_NewResults.Others, tbl_NewResults.Notes, tbl_NewResults.OK, tbl_NewLab.Area, tbl_NewResults.Urine_OK, tbl_NewLab.Period FROM tbl_NewLab INNER JOIN tbl_NewResults ON tbl_NewLab.PCode = tbl_NewResults.PCode WHERE (((tbl_NewResults.PCode) In (SELECT DISTINCT tbl_NewResults.PCode FROM tbl_NewLab INNER JOIN tbl_NewResults ON tbl_NewLab.PCode = tbl_NewResults.PCode WHERE tbl_NewResults.Pus IS NOT NULL AND tbl_NewResults.RBCs IS NOT NULL AND tbl_NewResults.Epithelial IS NOT NULL AND tbl_NewLab.Period = No ))); مستنداً في شرطه ومعياره على القيم التي في الاستعلام الفرعي السابق لقسم السجلات التي تشترك بـ PCode . وعليه ، يصبح الملف كالتالي مع التأكيد إن كان هذا السياق صحيح في نتائجه أم لا . JO R.zip

Code Converter 64.zip Code Converter 32.zip طبعاً لإفاداتكم بالنتائج ، يسعدني إبداء الرأي لمن هو مهتم بوظيفة الأداة . مع العلم أن النسبة المرجو تحقيقها في الوقت الحالي 70%. وهي نسبة تعتبر بالنسبة لي جيدة نوعاً ما لما في الموضوع من تشعبات كثيرة وكبيرة جداً جداً .. ولكن نسأل الله الوصول إلى أكبر نسبة من النجاح .

العفو أخي الكريم ، يسعدني أنه لبى حاجتكم .

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