كل الانشطه

إخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته في الملف المرفق Data126.rar جدول باسم tbl_Exams وجدول باسم tblTawzee ومربوطين بنموذج باسم frmTawzee وهوخاص بملاحظة المعلمين للجان وعند الضغط علي النموذج ( frmTawzee ) واختيار العام الدراسي ثم اختيار الفصل الدراسي ثم اختيار التاريخ والفترة والصف الدراسي سواء صف واحد أو اختار صفين ثم الضغط علي زر (اختر التاريخ والصفوف او احدها ثم انقر ) يجلب تقرير باسم ( molahza ) به جميع البيانات المشكلة عن الضغط علي زر (اختر التاريخ والصفوف او احدها ثم انقر ) لا يأتي بالبيانات وتظهر الرسالة الآتية ارجو الحل

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

لنجرب هدا مع إظافة الترتيب الأبجدي للعناصر في الـكومبوبوكس عند النقر المزدوج بحيث ترتب القائمة تلقائيا قبل العرض Option Explicit Dim WS As Worksheet Dim OnRng As Variant Dim ColArr As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("داتا") Dim f As Worksheet: Set f = Sheets("Sheet1") Dim lastRow As Long, cnt As Boolean, i As Long cnt = False lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(f.Cells(i, "A").Value) <> "" Then cnt = True Exit For End If Next i 'A' إظهار القوائم لغاية أخر صف يتضمن تاريخ على عمود' If cnt Then If Target.Count = 1 And Not Intersect(Target, Range("C2:O" & lastRow)) Is Nothing Then ' OR ' تحديد اخر صف لإظهار القوائم بما يناسبك ' If Target.Count = 1 And Not Intersect(Target, Range("C2:O100")) Is Nothing Then ColArr = Target.Column If xColumn(ColArr) Then On Error Resume Next OnRng = WS.Range(WS.Cells(2, ColArr), _ WS.Cells(WS.Rows.Count, ColArr).End(xlUp)).Value On Error GoTo 0 If Not IsEmpty(OnRng) Then If Not IsArray(OnRng) Then ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = WS.Cells(2, ColArr).Value End If Me.ComboBox1.List = Application.Transpose(OnRng) Else Me.ComboBox1.List = Array() End If With Me.ComboBox1 .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() Dim d1 As Object Dim tmp As String Dim i As Long Set d1 = CreateObject("Scripting.Dictionary") If Me.ComboBox1.Value = "" Then Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.DropDown Else tmp = UCase(Me.ComboBox1.Value) & "*" For i = 1 To UBound(OnRng, 1) If UCase(Trim(OnRng(i, 1))) Like tmp Then d1(Trim(OnRng(i, 1))) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown Else Me.ComboBox1.List = Array(Me.ComboBox1.Value) Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_Click() Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Function xColumn(colNum As Long) As Boolean Select Case colNum Case 3, 4, 5, 9, 10, 11, 15 xColumn = True Case Else xColumn = False End Select End Function Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next Dim listArr() As String, i As Long If Not IsEmpty(OnRng) Then ReDim listArr(1 To UBound(OnRng, 1)) For i = 1 To UBound(OnRng, 1) listArr(i) = OnRng(i, 1) Next i Call filtre(listArr) Me.ComboBox1.List = listArr End If Me.ComboBox1.Value = "" Me.ComboBox1.Activate Me.ComboBox1.DropDown On Error GoTo 0 End Sub Private Sub filtre(arr() As String) Dim i As Long, j As Long, temp As String, n As Long n = UBound(arr) For i = 1 To n - 1 For j = i + 1 To n If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then temp = arr(i): arr(i) = arr(j): arr(j) = temp End If Next j Next i End Sub تعديل 4 .xlsb

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

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

اطلعت على سجلاتهم .. كثير جدا منهم بين 15 و 12 وفيه 16.5 لا مشكلة نضع الضابط 20 او 23 .. حتى نضمن فتح المجال قلت للمالك يمكن العامل يوقع ويخرج ثم يأتي بعد 10 ساعات ويوقع خروج .. وكان رده .. لا تخف الكيمرات تسجل في كل مكان .. ويوجد متابعة .. لكننا نريد حفظ حقوق العمال لا يمكن تصور ما خط بالأحمر ولبدنك عليك حقا ... الحد الأقصى 16 ساعة ليتبقى له سويعات قليلة للنوم

اذا كان هذا العامل يعمل لأكثر من 15 ساعة ، فيمكن استثنائه من الشروط التي قيدنا بها العمل بحيث من خلال حقل Yes/No ان هذا العامل مستثنى !!! 🙄

جميل جداً ، جزاكم الله كل الخير معلمنا الفاضل على هذه الفكرة الجميلة الشاملة ,, كنت سابقاً استخدم فكرة بسيطة :- Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Dim newKeyCode As Integer Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyRight newKeyCode = vbKeyLeft KeyCode = newKeyCode Case vbKeyLeft newKeyCode = vbKeyRight KeyCode = newKeyCode End Select End Sub Private Sub Form_Open(Cancel As Integer) Me.KeyPreview = True End Sub لكن بعد التوسع الكبير العمل بما تقدمتم به من خلال الكلاس ، سأضطر لإعادة النظر بفكرتي المتواضعة 😅

اعرض الملف أشرطة التقدم المخصصة {سلسلة أدوات مساعدة مخصصة} تكملة لسلسة الأدوات المساعدة المخصصة أقد لك مثال لنموذج شريط التقدم موضحا فيه طريقة إستخدامه في كل السيناريوهات المعروفة (من وجهة نظري على الأقل) يحتوي تطبيق الأداة المرفق على نموذجين يقدمان ثلاثة أنواع من أشرطة التقدم الأول هو شريط التقدم الإفتراضي الشبيه بشريط ويندوز بلون أخضر صافي كما بالصورة التالية الثاني هو شريط تقدم ديناميكي يتغير حسب نسبة التقدم بمعنى أنه يبدأ باللون الأحمر ثم الأصفر وينتهي بالأخضر شريط التقدم الثالث هو شريط ملون تظهر فيه ألوان كل المراحل كما بالصورة بالرغم أن شريطي التقدم الأول والثاني نظريا يبدوان منفصلين ولكنهما في الواقع هما نفس النموذج وكل الإختلاف بينهما مجرد سطر في الكود ملاحظة إذا لم تظهر الخطوط لديكم كما بالصورة فيمكن تحميل الخطين AdvertisingBold و AL-Hor صاحب الملف منتصر الانسي تمت الاضافه 06/22/25 الاقسام قسم الأكسيس  

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

وعليكم السلام ورحمة الله وبركاته ,, تفضل هذا التعديل :- DDCompanyLogos.zip

الله يبارك الله فيك أخي الكريم

السلام عليكم لدي حقل اسم الصورة و حقل نوع الصورة اريد عند ادراج الصور يلزم المستخدم بملء الحقل الصورة و حقل نوع الصورة و اضافة كود لمعاينة الصورة واضافة حدف الصورة جزاكم الله خيرا DDCompanyLogos.rar

اعرض الملف إنشاء وإدارة الأشرطة المخصصة {سلسلة الأدوات المساعدة المخصصة} هذه المرة إليكم أداة مساعدة تساعد في إنشاء وتحرير وإدارة أشرطة الأوامر Ribbons بطريقة سهلة يجب تنزيل ملف الأيقونات من هذا الرابط ونسخ الأيقونات الى مجلد Office.2016.Icons حتى يعمل المثال التوضيحي بدون مشاكل أعتقد أنه قد تم شرح وتوضيح الخطوات بكثير من التفصيل مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 06/22/25 الاقسام قسم الأكسيس  

إذا سجل الموظف حضورا اليوم و خرج بدون انصراف ثم عاد بعد أسبوع لتسجيل بصمة فسيتم اعتبار البصمة الأولى حضور والثانية انصراف مما يؤدي إلى حساب ساعات عمل غير منطقية (أسبوع كامل) وبالنسبه للسؤال: كيف ستحسب ساعات العمل في هذه الحالة؟ وحضرتك تفضلت قائلا تحليلي: المشكلة حقيقية: في الخيار الثاني حيث البصمات متتالية (زوجي=حضور، فردي=انصراف) إذا نسي الموظف تسجيل انصراف وعاد بعد فترة طويلة سيتم ربط الحضور القديم بالانصراف الجديد مما يعطي ساعات عمل غير واقعية الحلول الممكنة:تحديد مهلة زمنية: عند حساب ساعات العمل استبعد الأزواج (حضور-انصراف) التي يزيد الفرق بينها عن حد معقول (مثل 15 ساعه أو مثل 24 ساعة) من خلال استعلام طيب مشكلة : ضابط يومي إذا أردت ضابط يومي يمكن تصفية البصمات حسب التاريخ في الاستعلامات لكن هذا يتعارض مع فكرة العملية المفتوحة بدلا من ذلك ممكن استخدام المهلة الزمنية اللى اقترحتها على حضرتك من شوية الخيار الثاني لا يزال الأفضل لأنه: يتماشى مع طبيعة العملية المفتوحة (15 ساعة+ عبر أيام) يتعامل مع البصمات المفقودة باستعلامات بسيطة ومهلة زمنية (مثل 15 ساعه أو مثل 24 ساعة) بدلا من برمجة معقدة لا يعتمد على افتراضات صارمة مثل إكمال EndTime عند العودة مقارنة الخيارين : الخيار الأول: إيجابيات: مباشر لحساب ساعات العمل إذا كانت السجلات مكتملة مع برمجة محكمة (مثل إجبار إكمال EndTime عند العودة) يمكن معالجة السجلات المفتوحة سلبيات: أقل مرونة لفترات العمل الطويلة (15 ساعة+) أو التي تمتد عبر أيام يتطلب برمجة إضافية لإدارة EndTime الفارغ والتأكد من التسلسل لا يزال غير مثالي لعملية مفتوحة حقا حيث قد تظل السجلات مفتوحة لفترات طويلة تقييم: يعمل إذا كنت مستعدا لاستثمار وقت في برمجة نموذج ومعالجات إضافية لكنه أقل مرونة الخيار الثاني: إيجابيات: مرن جدا لعملية مفتوحة يدعم فترات طويلة وعبر أيام يتعامل مع البصمات المفقودة بسهولة عبر استعلامات لا يحتاج إلى حقول فارغة أو تتبع حالة السجل سلبيات: يحتاج إلى استعلامات قد تكون أكثر تعقيدا لحساب ساعات العمل قد ينتج عن البصمات المفقودة ساعات عمل غير منطقية إذا لم تعالج (لكن يمكن حلها بمهلة زمنية) تقييم: أفضل لأنه يدعم العملية المفتوحة بدون قيود ويتطلب معالجة أقل تعقيدا مقارنة بالخيار الأول

اعرض الملف إستخدام أزرار الأسهم للتنقل في النماذج المستمرة كما في أكسل {سلسلة الأدوات المساعدة المخصصة} بعد سنوات طويلة من العمل ببرنامج الأكسس أصبح لدي مخزون ضخم من التطبيقات والأكواد التي إستفدت منها الكثير علمياً وعملياً خلال هذه السنوات وعندما كنت احتاج لتعلم طريقة عمل جزئية معينة كنت ألاقي صعوبة في إيجادها كحل مستقل بذاتة بل تكون إما ضمن برنامج متكامل فيصبح فصلها عن بقية مكونات البرنامج أكثر صعوبة أو أجد لها مثال ولكن قد يكون أقل أو أكثر من المطلوب بكثير والمشكلة أن أغلب تلك الحلول تكون في مواقع أجنبية بعد كل هذا أصبح لدي مجموعة من الأدوات التي غالبا مأستخدمها في تطبيقاتي منها ماهو من تطوير أشخاص آخرين بدون أن أقوم بأي تعديل عليها ومنها ماقمت تعديلها بالإضافة أو الحذف ومنها ماهو من تطويري أنا وقررت مشاركتها معكم رداً للجميل لهذا المنتدى وليكون مصدرا لمستخدمي أكسس من العرب سواء لحل مشكلة يواجهونها أو للتعرف على إمكانيات البرنامج التي قد لايكونون على علم بها لهذا قمت بإنشاء هذه السلسلة بإسم {سلسلة الأدوات المساعدة المخصصة} أقوم فيها برفع أداه تقوم بحل جزئية محددة بحيث يمكن لأي شخص الإستفادة منها في تطبيقاته بسهولة حتى ولم تكن له أي دراية بالأكواد مجرد نسخ ولصق وحاولت جاهداً إرفاق كل أداة بشرح يوضح طريقة عملها وطريقة الإستفادة منها نبدأ بإذن الله بأداة بسيطة تقوم بجعل التنقل خلال عناصر التحكم في النماذج المستمرة بإستخدام مفاتيح الأسهم شبيها للتنقل في ورقة أكسل وستجدون في المرفق نموذج يوضح طريقة عمل الأداة وطريقة الإستفادة منها في تطبيقاتك إن شاء الله يستفيد منها الجميع صاحب الملف منتصر الانسي تمت الاضافه 06/22/25 الاقسام قسم الأكسيس  

السلام عليكم ممكن رفع الملف هنا ... اللينك لا يعمل

وعليكم السلام ورحمة الله تعالى وبركاته أخي @sabah19672025 أعتقد أن طلبك غير واضح نوعا ما يمكن تنفيذ ذلك بعدة طرق حسب طريقة عملك واحتياجك ونحتاج فقط لتحديد الطريقة التي تفضل استخدامها: هل اختيار الملفات يدويا أي يتم عرض نافذة لتحديد ملفات PDF التي تريد نقلها (واحد أو أكثر) وسيقوم الكود تلقائيا بـإنشاء مجلد بنفس اسم كل ملف و نقل الملف إلى داخل هذا المجلد أم البحث داخل مجلد معين بحيث يتم تحديد مجلد يحتوي على الملفات المعنية و البحث داخله تلقائيا عن كل ملفات PDF مع إنشاء مجلد بنفس اسم كل ملف و نقل كل ملف إلى المجلد المناسب دفعة واحدة عموما إليك عدة إحتمالات يمكن إختيار ما يناسبك منها Sub test_MovePDF() Dim dl As FileDialog, selectedItems As Variant, fso As Object, i As Integer Dim xPath As String, xName As String, xFolder As String, newFolder As String Set dl = Application.FileDialog(msoFileDialogFilePicker) With dl .AllowMultiSelect = True .Title = "اختر ملفات PDF" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) xName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) newFolder = xFolder & "\" & Left(xName, Len(xName) - 4) If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & "\" & xName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '=================================== Sub Move_Selected_PDFs_To_Folders() Dim fso As Object, fd As FileDialog Dim i As Long Dim xPath As String, fileName As String, xFolder As String, newFolder As String Dim baseName As String Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملفات PDF المتفرقة" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" .AllowMultiSelect = True If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) fileName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) baseName = fso.GetBaseName(fileName) newFolder = xFolder & Application.PathSeparator & baseName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & fileName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '========================================= Sub test_Move_allPDF() Dim fso As Object, file As Object, newFolder As String Dim xFolder As String, xName As String, xPath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد الذي يحتوي على ملفات PDF" If .Show <> -1 Then Exit Sub xFolder = .selectedItems(1) End With Set fso = CreateObject("Scripting.FileSystemObject") For Each file In fso.GetFolder(xFolder).Files If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then xName = fso.Getn(file.Name) xPath = file.Path newFolder = xFolder & Application.PathSeparator & xName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & file.Name End If Next file MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub تحويل الى ملفات v2.xlsm

الف مبروك اخي الكريم fokash

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