Debug Ace

ولمن يتسائل عن عدد الدورات Public Function LastSurvivor(Optional ByVal lngN As Long = 10, Optional ByVal lngK As Long = 2) As Long Dim colPeople As Collection Dim lngIndex As Long Dim i As Long Dim killer As Long Dim totalCycles As Long Dim currentPosition As Long Dim stepKilled() As Long Set colPeople = New Collection For i = 1 To lngN colPeople.Add i Next i ReDim stepKilled(1 To lngN) lngIndex = 1 currentPosition = 1 totalCycles = 0 Do While colPeople.count > 1 lngIndex = ((lngIndex + lngK - 2) Mod colPeople.count) + 1 If lngIndex = 1 Then killer = colPeople(colPeople.count) Else killer = colPeople(lngIndex - 1) End If If currentPosition > lngIndex Then totalCycles = totalCycles + 1 End If currentPosition = lngIndex stepKilled(colPeople(lngIndex)) = totalCycles + 1 Debug.Print "السجين " & killer & " قتل السجين " & colPeople(lngIndex) & " (الدورة " & stepKilled(colPeople(lngIndex)) & ")" colPeople.Remove lngIndex If lngIndex > colPeople.count Then lngIndex = 1 Loop LastSurvivor = colPeople(1) Debug.Print "============" Debug.Print "الناجي الأخير هو السجين " & colPeople(1) Debug.Print "إجمالي عدد الدورات: " & totalCycles + 1 End Function اعتذر يبدو اننى لم احسن الفهم وتسرعت فى مسألة الشروط التى لم انتبه لها وبالنسبة لاجابة السؤال الاخير: اول مره اكتب هذه الوظيفة اساسا ولكن الموضوع يعتمد على الرياضيات البحته فى المقام الاول بدون فهم المنطق الرياضى لن تستطيع كتابة الكود ومن أجل ذلك ايضا تعمدت وضع المصدر

- بحثك عن الحل عن طريق الإنترنت. لم ابحث عن شئ أعرف القصة التاريخية فاللغز معروف باسم "مشكلة يوسف" نسبة إلى المؤرخ اليهودي يوسيفوس فلافيوس (Josephus Flavius) فقط وضعت المصدر اثراء للموضوع وزيادة فى المعرفة - إضافة خيارات غير مطلوبة في السؤال بسبب اعتمادك على مصدر خارجي وبسببه طال الكود. لا توجد اضافات ولذلك تم التعامل معها كمعاملات اختيارية بقيم افتراضية بناء على طرحك الغير كامل اساسا لاصل اللغز بناء على المنطق الرياضى البحت لتكتمل الفائدة لمن يريد الزيادة والاستفادة وكان ايضا ذلك هو السبب الثانى لوضع المصدر ولذلك لا توجد اى مخالفات ولا اطالة بدون داع فى الكود ونعم انا من كتبت الكود واشكرك على اطرائك

وظيفة واحدة تكفي لاجراء المطلوب Public Function SplitText(inputString As String, Optional extractNumbers As Boolean = False) As String Dim i As Integer Dim r As Integer Dim lets As String Dim result() As String Dim index As Integer Dim output As String r = Len(inputString) ReDim result(1 To r) index = 0 For i = 1 To r lets = Mid(inputString, i, 1) If extractNumbers Then If IsNumeric(lets) Then index = index + 1 result(index) = lets End If Else If Not IsNumeric(lets) Then index = index + 1 result(index) = lets End If End If Next i output = "" For i = 1 To index output = output & result(i) Next i SplitText = output End Function لاستخراج النص: SplitText([txtString]) لاستخراج الارقام : SplitText([txtString],True)

الكود Public Function LastSurvivor(Optional ByVal lngN As Long = 10, Optional ByVal lngK As Long = 2) As Long Dim colPeople As Collection Dim lngIndex As Long Dim i As Long Dim killer As Long Dim totalCycles As Long Dim currentPosition As Long Set colPeople = New Collection For i = 1 To lngN colPeople.Add i Next i ReDim stepKilled(1 To lngN) lngIndex = 1 currentPosition = 1 totalCycles = 0 Do While colPeople.count > 1 lngIndex = ((lngIndex + lngK - 2) Mod colPeople.count) + 1 If lngIndex = 1 Then killer = colPeople(colPeople.count) Else killer = colPeople(lngIndex - 1) End If If currentPosition > lngIndex Then totalCycles = totalCycles + 1 End If currentPosition = lngIndex colPeople.Remove lngIndex If lngIndex > colPeople.count Then lngIndex = 1 Loop LastSurvivor = colPeople(1) End Function الكود يعتمد على المصدر https://en.wikipedia.org/wiki/Josephus_problem

بالنسبة للعدد 7000 النتيجة = 5809 بالنسبة للعدد 500 النتيجة = 489 بالنسبة للعدد 10 النتيجة = 5

شكرا جدا جدا جدا لحضراتكم

سلام عليكم من فضلكم عاوزة اعمل شئ ومش عارفه اعمله ازاى عندى نموذج عاوزة اضيف فيه اكتر من مربع نص وليكن 50 مربع نص ازاى اخلى اسماء مربع النص على الترتيب بالشكل الاتى مثلا officena1 officena2 officena3 officena4 لحد ما نوصل لـ officena50

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

سلام عليكم انا كنت لاقيت قاعدة البيانات دى حاولت التعديل عليها بس معرفتش عاوزة اعمل جدول احدد منه اسماء العطلات الاسبوعية يعنى لو الجمعة بس ولو فى مكان تانى الجمعة والسبت و..... وهكذا عاوزة اعمل جدول يتم منه تحديد لون الخلفية لايام العطلات ولون الخط الفايدة من الجداول ( علشان يكون فى مرونه فى التحكم بعيد عن الدخول لتعديل التصميم والنتيجة طبعا فى نموذج النتيجة الشهرية لما تفتح عاوزة لون الخلفية والنص لمربعات العطلة او العطلات الاسبوعية على مدار الشهر حسب البيانات من الجداول DatePicker.accdb

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

السلام عليكم من فضلكم عاوزة اضيف سجلات لجدول محدد عن طريق استخدام حلقة تكرارية من تاريخ بدايه الى تاريخ نهايه لكن بشرطين عدم اضاقة ايام الجمعه والسبت التى تكون ضمن تاريخ البدايه وتاريخ النهايه عدم اضافة تواريخ محدده من جدول أخر و التى تكون ضمن تاريخ البدايه وتاريخ النهايه يعنى مثلا انا عرفت احقق الشرط الاول بس مش عارفة احقق الشرط الثانى المفروض طبقا للمثال المرفق عدم اضافة ايام 06/01/2022 12/01/2022 13/01/2022 مثال.mdb

جرب استبدال السطر بهذا الكود واخبرنى بالنتيجة #If Win64 = 1 And VBA7 = 1 Then Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As LongPtr, clr As LongPtr) '---color Picer #Else Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As Long, clr As Long) '---color Picer #End If

شكرا استاذ @أبو إبراهيم الغامدي شكرا استاذ @ابا جودى الله يبارك لكم فى علمكم

والله لو ينفع اعمل 1000 لايك كنت عملتها بجد شكرا

اهلا ومليون اهلا بيك استاذ @أبو إبراهيم الغامدي انا كتير متشكره ليك جدا جزاكم الله كل خير

الامر Debug.Print بيظهر حسب الكود البيانات فى النافذة الفورية Immediate داخل محرر الاكواد انا عاوزة الفيم تروح على مربع قائمة فى النموذج هو بيجبلى اخر سطر بس زى ما بيظهر فى النافذة الفورية Immediate ازاى نخليه يجيب كل الاسطر

سلام عليكم انا استخدمت كود لاظهار اسماء اوراق العمل لاى شيت اكسل بعد اختياره وكله كله تمام بس المشكلة اللى مش عارفه احلها ان اسماء الشيتات بتظهر بس فى النافذة الفورية Immediate عاوزة انها تظهر فى القائمة اللى فى النموذج زى ما ظهرت بالظبط فى النافذة الفورية Immediate Import Excel.zip

السلام عليكم ورحمة الله وبركاته كنت ابحث على الانترنت عن طريق استيراد بيانات من شيت اكسل يحتوى على الكثير من اوراق العمل ولكن اريد قائمة تظهر اوراق العمل بداخل ملف الاكسل ليتم تحديد ورقة العمل التى نريد اجراء عملية الاستيرا للبيانات التى بداخلها وجدت مثال فى موقع اجنبى ولكن به مشكلة لم استطيع حلها وهى عدم الاستيراد عند وجود خلية فارغة مرفق مثال لملف الاكسل وقاعدة البيانات برجاء تعديل هذه المشكلة وهناك سؤال اخر فى نفس السياق هل يمكن التعديل بحيث نبتعد عن اختيار مكتبة الاكسـل من محرر الاكواد لانها تعطى خطأ باختلاف نسخ الاوفيس جزاكم الله خيـــــــــرا Import Excel Example.zip

وانت بنفسك قلت ولي عودة عند ما يكون للعودة جدوى

غير السطر ده ب DoCmd.Quit ولي عودة عند ما يكون للعودة جدوى

لا خااااااااااالص مالهاش حل حتى لو عملتها بباسورد بتتفتح ههههههههههههه انا رخمه قفلتهالك

انا مش فاهمه انت يعنى لاقيت الحل اللى انت عايزه واللا لسه

ممكن ده

ممكن بفكرة بس مش هعرف اعملها انا اقول لك على الفكرة وانت شوف حد يعملها لك 1- اعمل قاعدة بيانات مرفقة داخله جوة قاعدة البيانات الاصلية اللى انت عاوز لو اتغيرت ترجعها تانى فى القاعدة المرفقة دى اعمل كود انها تجيب لك اسم القاعدة اللى معاها فى المسار وتقارنه بالاسم القديم لو تمام خلاص لو مش تعمل رنيم بالاسم القديم 2- عند فتح نموذج الدخول مثلا يحمل القاعدة المرفقة للمسار فى حالة ان اسم القاعدة اللى شغاله اتغير لما تعمل له مقارنه ويقفل القاعدة الحاليه 3-القاعدة المرفقه لما تفتح هى تعمل رينيم اليا وتفتح القاعدة الاصلية وتقفل نفسها هى لفة بس اعتقد انها فكرة ممكن تنفذ اللى انت عاوزه ههههههههههههههههههه شوف مين بقه ممكن يعمل لك الافكار دى لان انا ما اعرفش بصراحة انا المخ وانتم العضلات انا بصراحة مش فاهمه حجات كتير باحاول اتعلم افكر وانفذ لسه

لو الكلام من فضه يبقى السكوت من دهب