Foksh

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

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

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

وعليكم السلام ورحمة الله تعالى وبركاته 🤗 واجهتني مشكلة سابقة في ويندوز 11 مع أوفيس 2016 ، وكانت المشكلة في تحديثات الويندوز اللي كانت مع النسخة ، وللأسف بعد العودة الى ويندوز 10 ونفس نسخة الأوفيس 2016 ، لم أواجه المشكلة ذاتها.

أخي أسعد ، وعليكم السلام ورحمة الله وبركاته ،، أولاً تقبل الله طاعاتنا وطاعاتكم ، وكل عام وأنتم بخير . دائماً ما ننوه ونذكر حريصين على مساعدتكم بضرورة تحديد تفاصيل المشكلة وإرفاق ملف حتى وإن تكرر نفس الملف في مشاركات ومواضيع ومشاكل سابقة . كما أُشير إليك بذكر سبب استفسارك عن صحة الدالة ( المشكلة التي تواجهها ) . بما انك استخدمت First في استعلامك ، فأعتقد وأنه من الأفضل لك استخدام الترتيب في نتائج الاستعلام ORDER BY . قد نسيت بنية الاستعلامات السابقة في مشاريعك . لذا حاول استخدام الفرز حسب قيمة معينة ليتم جلب أول قيمة لك من نتيجة الإستعلام .

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

أخي الحبيب @kkhalifa1960 ، دائماً تذكُرنا بمناسباتنا ، فكل الشكر والتقدير لك ولشخصك الكريم . وتقبل الله منا ومنكم صالح الاعمال والطاعات ، وجعله في ميزان حسناتكم 🤗 . وكل عام وأنتم بخير جميعاً.

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

وبارك بكم ، ونفع بكم شكراً لمرورك العطر 💐

حياك الله اخوي الغالي لنفترض أن لدينا حقلًا في جدول باسم LinkName كما في مثالك ، ويحتوي على الرابط التشعبي التالي : "Visit Google#https://www.google.com#Homepage" نتيجة HyperlinkPart([LinkName], 1) : "Visit Google" (النص الظاهر) . نتيجة HyperlinkPart([LinkName], 2) : "Homepage" (العنوان الفرعي) . نتيجة HyperlinkPart([LinkName], 3) : "https://www.google.com" (الرابط الأساسي) . متى نستخدم كلاً منهما ؟ استخدم 1 عندما تريد عرض النص الذي يراه المستخدم فقط (حسب مثالك طبعاً ) استخدم 2 عند الحاجة إلى استخراج إشارة مرجعية أو موقع داخل ملف ( مثل اكسل أو وورد ) استخدم 3 لاستخراج الرابط الفعلي ( URL أو مسار الملف ) فاستخدمت 1 لما يتوافق مع مثالك الذي طرحته ، ولكن جرب الحالة 3 😉 .

وعليكم السلام ورحمة الله وبركاته .. من خلال الملف اعتقد ان المشكلة لديك في فقدان الخط QCF_BSML من الويندوز وعدم وجوده . لذا تستطيع تحميل النسخة 2005 من هنا ، أو النسخة الجديدة كاملة من هنا . مع العلم أن الخطوط التي تريدها هما :- Desktop.zip فقط قم بتثبيتهما على جهازك وافتح الملف بعدها .

وعليكم السلام ورحمة الله وبركاته .. بعد النظر الى ملفك المرفق من الجوجل درايف ، انظر للخطأ الذي ظهر حيث ان أسماء الحقول لديك هي ارقام في بعض الجداول . فإن كانت البدايات تحتوي على مشاكل ، فسيتم دائماً وجود مشاكل لاحقاً . أيضاً في الجدول Time Cards ، الحقل ID نوعه ترقيم تلقائي ولكنك استخدمت التنسيق "TCN "0000 = اي انه يحتوي على نص ورقم في حقل نوعه ترقيم تلقائي . وعليه لم أكمل النظر في المرفق لأخطاءه الكثيرة ,, ثانياُ ، لم تذكر اسم التقرير للأسف . ثالثاً ملف الآكسل يحتوي اسماء العناوين نصوص وليست أرقام !!! وانت لم تفسر وتشرح وتوضح مطلبك بشكل واضح للقارئ .

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

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

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

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

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

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

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

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

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

شو يعني ، ما فهمت أخي الكريم 😅

وعليكم السلام ورحمة الله وبركاته ،، أهلا بعودتكم أستاذنا الفاضل @منتصر الانسي ، وبعد عودتكم بفكرة جميلة جداً .. فسلمت على هذه الفكرة الجميلة اهتمامك حتى بفكرة الترقيم لللفاتورة جاءت بطريقة ذكية

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