كل الانشطه

تسلموا والله استفدنا جدا بارك الله فيكم ولاعجب في ان يكون هذا المتندى الاول والافضل عندي جميعكم رائعون متميزون المشكله نجد صعوبة في تنزيل الملفات من فورد شير حاولت عدة مرات ولا استطعت نرجو تحميل في ميديا فاير

تسلموا والله استفدنا جدا بارك الله فيكم ولاعجب في ان يكون هذا المتندى الاول والافضل عندي جميعكم رائعون متميزون

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

وهذا حل ثالث اقصر Function JosephusOneLine(n As Integer) As Integer JosephusOneLine = 2 * (n - 2 ^ Int(Log(n) / Log(2))) + 1 End Function

حلول ذكية منقولة الحل الأول: Function Survivor(pCount As Integer) As Variant Dim Res As String Survivor = "#NUM!" If pCount < 1 Or pCount > 511 Then Exit Function Res = WorksheetFunction.Dec2Bin(pCount) Res = Mid(Res, 2) & Left(Res, 1) Survivor = WorksheetFunction.Bin2Dec(Res) End Function الحل الثاني: Function Survivor(pCount As Integer) As Integer Dim Prisoners As String Dim k As Integer, v As Integer Prisoners = String(pCount, "1") Do While Replace(Prisoners, "0", "") <> "1" k = InStr(v + 1, Prisoners, "1"): If k = 0 Then k = InStr(1, Prisoners, "1") v = InStr(k + 1, Prisoners, "1"): If v = 0 Then v = InStr(1, Prisoners, "1") Prisoners = Left(Prisoners, v - 1) & "0" & Mid(Prisoners, v + 1) Loop Survivor = InStr(1, Prisoners, "1") End Function آمل من المشرفين الكرام إقفال هذا الموضوع فقد وئد في يومه الأول. شكرا للجميع.

😇 تحديث 1- تصحيح التوقيت التنفيذ للاحتساب عن طريق دالة بسيطة 2- اضافة تاب سفلي كتغير واضافة الى النافذة بطريقة سهلة ---------------------------------------------- =========================() تحميل المرفق https://www.mediafire.com/file/g4uyr43fywxh1jy/Update_Silent-Print-with_Out_PDF.rar/file

مرفق شيت به 1000 اختصار لبرنامج الاكسيل لتسهيل العمل منظم حسب الاصدارات للاستاذ/ محمود سيد جزاه الله خيرا 1000 اختصار للاكسيل محمود سيد.xlsx

الله يعطيك العافيه شكرا لك اخي🌹

من داخل الدالة المرفقة ، تستطيع حتى جعله = زحلون مريخي الزحلون المريخي عملة مريخية هههههههههه ( امازحك 😅 )

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

وعليكم السلام ورحمة الله وبركاته .. نعم أخي تستطيع ذلك ، في المرفق التالي فكرة مشتقة من أحد المشاريع القديمة ، وتقوم بنفس الطلب الذي تريده . فقط املأ الارقام وانقر زر ارسال واتس اب تم حذف بعض الوظائف الخاصة بالمشروع الأصلي .. WhatsApp Sender WF.accdb

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

الكود عمل محترف وسريع. هناك مخالفتين منك 🙂 : - بحثك عن الحل عن طريق الإنترنت. - إضافة خيارات غير مطلوبة في السؤال بسبب اعتمادك على مصدر خارجي وبسببه طال الكود. - يمكن اختصار الكود ورفعه كمشاركة ثانية وأخيرة. إذا أنت من كتب الدالة وكتبتها بعد قراءتك للسؤال فأنت محترف وصانع متمكن للأكواد. تعلمت من دالتك استخدام كائن Collection

أستاذ يمكن الوصول للحل بدون معرفة عدد الدورات.

السلام عليكم ورحمة الله وبركاته الله يعطيك العافيه على العمل الرائع والمميز جدا اخي الفاضل @Foksh عندي تقرير من صفحه واحده هل الابامكان ارسال التقرير PDF كمرفق بطريقة تلقائيه بدون ادراجه من الجهاز كيف تكون الطريقه جزاك الله خير وبارك فيك وبعلمك

وظيفة واحدة تكفي لاجراء المطلوب 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

اشكرك على الترحيب ولكن دعني لاخر واحد في المشاركة لاني اعرف الاجابة مسبقا .. اترك المجال للاخرين ..

وعليكم السلام ورحمة الله وبركاته .. السؤال المنطقي هو ، في كم دورة تمت حتى وصل السجين 73 الناجي الوحيد !!!

ولما لا؟!، أسمك مألوف لدي جيدا ولكن لا أتذكر أي أحداث بيني وبينك، والحمد لله من نعم الله علي أني كثير النسيان وهذا يسهل علي التعامل مع الناس. أحييك على حماسك ولتكن أنت البادئ.

جزاكم الله خيرا على المساعده

@ابو جودي والبتعله الحوت اشرايك بشعار 😂 1- تنفيذ امر الاستخراج والطباعة صامت من غير صندوق الرسالة اجراء الطباعة وعد الصفحات انتظار فقط 2- كود مبسط ثلاث حقول 'Selected Objecit Print = (1) or PDF = (2) حدد النوع Type_Object = 2 'Name_report اسم التقرير reportName = "report1" 'If PDF Out Path File مسار الاستخراج pdfPath = CurrentProject.Path & "\" & reportName & "_" & Format(Now(), "yyyymmdd_hhnnss") & ".pdf" فقط Private Sub Comando0_Click() '=============================( Msgbox Dim strMsg_Give_Nmae As response Dim Run_Cod1 As Integer Dim MsG1 As String Dim MsG2 As String Dim MsG3 As String Dim iprgrs As Integer Dim PDF_Print_Finction As String Dim path_pdf As String Dim Report_T As String Dim Type_Object As String Dim reportName As String Dim pdfPath As String Dim totalPages As Long 'Selected Objecit Print = (1) or PDF = (2) Type_Object = 2 'Name_report reportName = "report1" 'If PDF Out Path File pdfPath = CurrentProject.Path & "\" & reportName & "_" & Format(Now(), "yyyymmdd_hhnnss") & ".pdf" '=========================================================================================================== '*****************(Only_Code)***************************** ' جلب إجمالي الصفحات للتقرير totalPages = GetReportPageCount(reportName) Me.ProgressBar3.Min = 0 Me.ProgressBar3.Max = totalPages Me.ProgressBar3.Value = 0 If Not ReportExists(reportName) Then MsG2 = "Sand Massage !" MsG1 = "تم الغاء التنفيذ " MsG3 = " لالتقرير غير موجود ولم نتمكن من العثور علية " MyMsgBox (MsG3), (MsG2), (MsG1), msg_Erorr_Job, Btn_Non, Arabic_Center ', True, 2.5 Exit Sub End If Me.Comando0.Caption = "جار التنفيذ..." Me.xc.Caption = "اجمالي الصفحات.." & totalPages For iprgrs = 1 To 6 'totalPages - 1 Me.ProgressBar3 = iprgrs Next If Type_Object = 2 Then Call externallyPDFSilent(reportName, pdfPath) Me.Comando0.Caption = "تصدير التقرير" End If If Type_Object = 1 Then Call externallyPrintSilent(reportName, pdfPath) Me.Comando0.Caption = "طباعة التقرير صامت" End If ' تحديث ProgressBar (هنا تحديث مبدئي، يمكنك توسعتها في حالة التصدير صفحة صفحة) Me.ProgressBar3.Value = totalPages Me.xc.Caption = "جاري المعالجة... 100%" Call externallyPrintSilent(reportName, pdfPath) If Dir(pdfPath) <> "" Then If Type_Object = 2 Then MsG2 = "Sand Massage !" MsG1 = "تم التنفيذ تصدير PDF " MsG3 = " لا يتوفر الان عملية تأمين الالي للبيانات بتاريخ واليوم " MyMsgBox (MsG3), (MsG2), (MsG1), msg_OK, Btn_Non, Arabic_Center ', True, 2.5 End If If Type_Object = 1 Then MsG2 = "Sand Massage !" MsG1 = "تم التنفيذ الطباعة " MsG3 = " لا يتوفر الان عملية تأمين الالي للبيانات بتاريخ واليوم " MyMsgBox (MsG3), (MsG2), (MsG1), msg_OK, Btn_Non, Arabic_Center ', True, 2.5 End If ' MsgBox "تم إنشاء ملف PDF بنجاح:" & vbCrLf & pdfPath & vbCrLf & _ ' "إجمالي الصفحات: " & totalPages, vbInformation End If End Sub تحميل المرفق https://www.mediafire.com/file/wrl147f1wl7uwmk/Silent-Print-with_Out_PDF.rar/file