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 لايك كنت عملتها بجد شكرا

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