نجوم المشاركات

لدي هذا التطبيق يقوم باختبارات ادارية متنوعة ارجو ان تبدو رأيكم فيه مع جزيل الشكر Administrative_Tests.rar

وعليكم السلام ورحمة الله وبركاته جرب الكود في الملف المرفق 1الجرد.xlsm

السلام عليكم ورحمة الله وبركاته اقدم لكم شرح مبسط لطريقة بحث احترافيه في شيت اكسل رابط الفيديو لتحميل ملف العمل https://www.mediafire.com/file/4t7skm26bdj2mhk/salloum.xlsx/file

ممكن يكون طلبك هنا https://www.youtube.com/watch?v=M1DhpzkT8kA او جرب هذا الكود: Sub Observer_FullSystem() Dim ws As Worksheet, wsReport As Worksheet Dim NamesArr() As Variant Dim UsedRow As Object, UsedCol As Object, UsedAll As Object Dim lrNames As Long, lrRows As Long, lrCols As Long Dim r As Long, c As Long, i As Long Dim Available() As String Dim cnt As Long, MaxAllowed As Long, TotalCells As Long Dim TryCount As Long Dim MainCols As Long: MainCols = 2 ' عدد الأعمدة الأساسية Set ws = ActiveSheet Application.ScreenUpdating = False Randomize ' ===== Backup ===== ws.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Backup_" & Format(Now, "ddmmyy_hhmmss") ws.Activate ' ===== قراءة الأسماء ===== lrNames = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row NamesArr = ws.Range("B3:B" & lrNames).Value ' ===== حدود الجدول ===== lrRows = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row lrCols = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)).ClearContents ' ===== الحد الأقصى ===== TotalCells = (lrRows - 2) * (lrCols - 3) MaxAllowed = Application.WorksheetFunction.RoundUp(TotalCells / (lrNames - 2), 0) Set UsedAll = CreateObject("Scripting.Dictionary") ' ===== التوزيع ===== For r = 3 To lrRows Set UsedRow = CreateObject("Scripting.Dictionary") For c = 4 To lrCols TryCount = 0 RetryCell: TryCount = TryCount + 1 If TryCount > 300 Then GoTo NextCell Set UsedCol = CreateObject("Scripting.Dictionary") For i = 3 To r - 1 If ws.Cells(i, c).Value <> "" Then UsedCol(ws.Cells(i, c).Value) = 1 Next i cnt = 0 ReDim Available(1 To UBound(NamesArr, 1)) For i = 1 To UBound(NamesArr, 1) If Not UsedRow.exists(NamesArr(i, 1)) _ And Not UsedCol.exists(NamesArr(i, 1)) Then If Not UsedAll.exists(NamesArr(i, 1)) _ Or UsedAll(NamesArr(i, 1)) < MaxAllowed Then cnt = cnt + 1 Available(cnt) = NamesArr(i, 1) End If End If Next i If cnt > 0 Then ws.Cells(r, c).Value = Available(Int(Rnd * cnt) + 1) UsedRow(ws.Cells(r, c).Value) = 1 UsedAll(ws.Cells(r, c).Value) = UsedAll(ws.Cells(r, c).Value) + 1 Else GoTo RetryCell End If NextCell: Next c Next r ' ===== تقرير ===== On Error Resume Next Set wsReport = Sheets("تقرير") On Error GoTo 0 If wsReport Is Nothing Then Set wsReport = Sheets.Add wsReport.Name = "تقرير" Else wsReport.Cells.Clear End If wsReport.Range("A1:D1") = Array("الاسم", "الإجمالي", "أساسي", "احتياطي") For i = 3 To lrNames wsReport.Cells(i - 2, 1) = ws.Cells(i, 2) wsReport.Cells(i - 2, 2) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, lrCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 3) = Application.CountIf(ws.Range(ws.Cells(3, 4), ws.Cells(lrRows, 3 + MainCols)), ws.Cells(i, 2)) wsReport.Cells(i - 2, 4) = wsReport.Cells(i - 2, 2) - wsReport.Cells(i - 2, 3) Next i wsReport.Columns.AutoFit Application.ScreenUpdating = True MsgBox "تم التوزيع + إنشاء نسخة احتياطية + تقرير كامل ?", vbInformation End Sub

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

اعلم هذا وواضح بالملف وعملت في قطاع التعليم التقني والتوجيه الفني 39 سنة واعلم جيدا كيف عمل اللجان لم يكن الامر يتطلب كل هذا على كل حال عودة للملف اليك الملف بالتعديل الاخير مراقبة_ تحويل اللجان الى أسماء.xlsm

اليك ما طلبت بالتنسيق الشرطي aaaa2.xlsm

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

تفضل تعديل بسيط على الشرط عدم الاقتطاع 5.rar

تسلم استاذنا الغالي والف شكر كفيت ووفيت

في مرفقي الاخير .. في شرط المتغير تم تصحيح الشرط فعمل معي

تفضل استاذ @Emad.85 المرفق بطلبك ووافني بالرد . Emad.85.rar

اخي الكريم ذكرت انظر في الكود في فورم FrmTransfer1 بينما البرنامج يفتح على FrmTransfer والكود cmd_Pay_installments موجود في النموذجين لا اخفيك تهت .. اذا العمل على FrmTransfer1 لماذا FrmTransfer موجود ؟ اذا يوجد ازرار غير مهمة احذفها .. هذا مجرد مثال

اخي طاهر .. خذني على قد فهمي اريدك ترفع مرفق يكون الجدول الخاص بالاقتطاعات خالي اعتقد انه الجدول tbl_Loans كما اظن وتشرح لي بالخطوات اعمل ايه من خلال النموذج .. خطوة خطوة وصورة للنتيجة المفترض الحصول عليها

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

شكرا استاذي العزيز

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

شكرا كبير يا استاتنا الفاضل يارب اجعل هذا العمل في ميزان حسنات استاذ الفاضل kkhalifa1960

تفضل استاذ @محمد حسن2 محاولتي اليك الشرح والمرفق . بعد اختيار المرفقات واختيار اسم الفولدر ومسار الحفظ والضغط على الزر نسخ بيعمل لك فولدران بالمسار الذي اختارته واسمه . فولدر به كل الملفات المختارة والثاني نفس الفولدر مضغوط وبنهاية البروجرسبار بيفتح جوجل درايف ز والتكملة بالفيديو التالي . BackUpTest.rar

جزيت خيرا مؤكد لن نعدم فائدة .. فجزاك الله خيرا سوف نتصفحه و نقتبس اجمل ما فيه .. وندعوا لك ولن نستغني عن تفاعلك ومشاركتك معنا

البرنامج ممتاز ... ولكن عند تشغيلة يظهر بهذه الصورة زاحفا نحو اليسار الى الاسفل يبدو بسبب هذا الكود عند الفتح Private Sub Form_Current() Me.Form.InsideHeight = 9000 Me.Form.InsideWidth = 17000 CenterFormOnScreen "frm-UserLogon" End Sub

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

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

شكرا جزيلا استاذ

مـــــبدع مهندســـنا الطيب , جزاك الله خير الجزاء

تم عمل التعديلات على النحو التالي : - اضافة جدول وسيط يحمل درجة الاجابة - تغيير كود الحاق الاجابة واستبداله باستعلام الحاق - اضافة بعض الضوابط مثل : الاغلاق بعد الحفظ منع اعادة الاختبار ( آلية مرنة يمكن للمسؤول تمكينه من اعادة الاختبار حيث اضفت حقل نعم/لا يمكن التحكم من خلاله) بعض اللمسات على نموذج الاجابة ....................................................... لترتيب هذا العمل .. مهم جدا العمل على آخر مثال تم التعديل عليه من قبل الاخوة الكرام وحبذا يراعى في الامثلة الترتيب الرقمي .. فالمرفق الجديد سميته Exam1 فيا ليت يكون التالي Exam2 .. وهكذا ... انتظر منكم الملاحظات او اي تعديلات قبل الانتقال للخطوة والمطلب التالي Exam1.rar

شكرا استاذ عمر على المشاركة الجميلة تحقق من الخطوة الأولى 1- ضبط الوقت .. وغلق النموذج عند انتهائه 2- حفظ الاجابة في جدول tbl_Answers 3- عمل جدول اعدادات عامة ملاحظة : بعد التجربة اتضح لي وجوب ايجاد جدول وسيط لرصد الاجابة المبدئية في الوضع الحالي سيتم حفظ الفقرة الأخيرة اي اجابة سؤال واحد فقط انتظروني سأعمل على ذلك

الدالة ستكون هكذا : التغير في مكانين .. بداية الرقم اصبح 6 بدلا من 5 والسطر الأخير يمكنك وضع الفاصلة التي تريد بدلا من "-" Public Function GenerateID(TableName As String, fieldName As String) As String on error resume next Dim vLastY As Variant Dim iNext As Integer vLastY = DMax(fieldName, TableName, fieldName & " LIKE '" & Year(Date) & "*'") If IsNull(vLastY) Then iNext = 1 Else iNext = Val(Mid(vLastY, 6)) + 1 End If GenerateID = Year(Date) & "-" & Format(iNext, "000000") End Function

يعني استمر في التعديل على هذه النسخة وبالطريقة التي ذكرتها

قمت بنقل النظام الى جهاز لابتوب اخر و عليه نفس اصدار الاوفيس و كذلك نفس اصدار الويندوز و كذلك نفس اصدار الواتس اب و اشتغل طبيعي جداً بينما في الجهاز الأول مارضي سأحاول اعاده تثبيت الاوفيس في الجهاز الاول شكراً لك اخي @Foksh على الرد و اعذرني ان ازعجتك بكثره الاسئله

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

تريده هكذا أستاذ يوسف ؟ 🙂 JO_Lab.rar

اعرض الملف إداة تخصيص مربع الرسائل MsgBox {سلسلة الأدوات المساعدة المخصصة} نواصل سلسلة الأدوات المخصصة بأداة بسيطة وسهلة الإستخدام ولكن نتيجتها رائعة فكما نعلم فإن صندوق الرسائل MsgBox القياسي يأتي بإمكانيات محدودة كعدم إمكانية تنسيق الخطوط وتغيير مسميات الأزرار وغيرها من الأمكانيات وهنا تأتي هذه الأداة لتقوم بكل مايعجز مربع الرسائل القياسي عن القيام به حيث يمكنها - إنشاء الرسائل بنص غني RichText وهذا يعني أمكانية التحكم في تنسيق النص من حيث نوع الخط ولونه وحجمه وتسطيره ... الخ - تعيين تسميات الأزرار مع إمكانية تغيير لونها - الإغلاق التلقائي وغيرها من المميزات التي ستتعرف عليها في الملف المرفق طريقة إستخدام الأداة بسيط للغاية فمن خلال نموذج (المعالج) نقوم بكتابة وتنسيق نص الرسالة وتعيين خيارات مربع الحوار ثم إستعراض شكل مربع الرسالة الناتج عن هذه التحديدات حتى يتم الوصول للنتيجة المطلوبة ليقوم النموذج بإنشاء صيغة الكود الذي يقوم بتنفيذ الأمر لنسخه ولصقه في المكان المطلوب ملاحظة هامة : ارجو التركيز على الملاحظات المكتوبة باللون الأحمر في النموذج لأنها ملاحظات هامة يجب إستيعابها تحياتي صاحب الملف منتصر الانسي تمت الاضافه 12/18/25 الاقسام قسم الأكسيس  

وعليكم السلام ورحمة الله وبركاته .. جرب هذا التعديل أخل الكريم .. DCOUNT.zip

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

تفضلي التعديلاات كالتالي : 1- وضعت الوان في النموذج الرئيسي للاستدلال على الخطابات التي تم الاطلاع عليها .. الاخضر تم والبرتقالي لم يتم 2- في حدث العداد للنموذجين الفرعيين جعلت الوقت 5 ثواني ( كل 1000= ثانية ) يمكنك زيادة الوقت وهو الافضل مثلا 300000 = 5 دقائق بمعنى كل 5 دقائق يتم تحديث النموذج لمعرفة ان كان هناك خطابات جديدة الآن عند فتح النموذج الفرعي سيفتح بلا بيانات انتظري 5 ثواني لتري التيجة جربي ووافيني بملاحظاتك مراسلة3.rar

انظر هذه الخطوة الاولى تم التصرف في المفاتيح حسب حاجة التصميم ( الاختيار العشوائي سيتم على المفاتيح ) فقط حتى تتخيل كيف سيكون الاخراج الخطوة التالية هي 1- تشغيل الاختيار العشوائي 2- ربط النموذج الفرعي بجدول الاجابات 3- تشغيل الوقت الاختيار العشوائي يتم عند فتح النموذج من غير تدخل يدوي او ازرار اذا اعجبك العمل واردت ان نستمر يا ليت تفتح موضوع جديد وعنوان جديد مناسب مثلا برنامج اختبارات او قياس قدرات او تقييم مهارات ونحو ذلك مما ينطبق على غرضك لأن العمل يستحق ذلك التعليق والملاحظات مفتوح للجميع .. باعتباره موضوعا ودرسا تعليميا new_test1.rar

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

دائما لك نكهة خاصة مميزة 😋👌🌹 إبداع وإمتاع

هذه الصور تبين النتيجة تصميم ثم عرض .. العرض يتم لجميع الطلاب

ما شاء الله تبارك الرحمن 🙂 جميل جدا تنوع الأفكار في نفس المجال 😊👌 وأنا أيضا لدي برنامج خاص بتصميم الشهادات وتنسيقها وتوليد الشهادات لمجموعة كبيرة من الطلاب أو المتدربين أو المستلمين بشكل عام ، وكذلك يقوم بإرسال الشهادات بالبريد الإلكتروني لكل المستهدفين ( كل متدرب أو طالب يستلم شهادته) ، وأيضا يقوم بحفظ جميع الشهادات على شكل Pdf دفعة واحدة .. 🙂 مع إمكانيات تنسيق النص ( الخطوط والألوان ) بشكل حر ، وإضافة التواقيع ، وتغيير إطارات البرنامج .. إلخ تصميم وتنسيق النصوص بكل أريحية إضافة المتدربين دفعة واحدة بعدد لا محدود معاينة بشكل مباشر اواجهة البرنامج مع خيارات البحث وعرض تقارير وإحصائيات لتحميل البرنامج : تنصيب برنامج صانع الشهادات الإصدار الثالث 3.0.zip

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

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm

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

من الملفات القديمة التي تمت مشاركتي لها والتي تطلب غالباً كيف نحمي الخلايا غير الفارغة بواسطة باسوورد (الباسورد في الملف / الخلية H3/ يمكن حفظة و مسحه عن عيون الفضوليين) مع حرية الغاء الجماية كما تشاء protect non empty data with Pass word.xlsm

اليك الملف بعد اضافة المعادلة تحياتي كشف لمن غاب اكثر من 3.xlsm

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

ممكن ذلك شاهد هذا الملف (العملية تتم عند كبسة اليمين وليس دوبل كليك في نطاق محدد ) كله قابل للتغيير حسب المطلوب Right_Click.xlsm

اخي الكريم ابو أحمد السلام عليكم ورحمة الله وبركاته تم ضبط كود شهر نوفمبر بالمرفقات مع تحياتي Charts Form.rar

اولاً الف مليون شكر للاستاذ مصطفى على حله الرائع ثانيا اخي محمود المرفق فيه المطلوب (الحل بالتصفية المتقدمة) ابواحمد محمود علاء.rar