كل الانشطه

جرب هذه النسخة ، وطابق النتائج . فكرة توزيع تلقائي لمستويين (4).mdb

تمام .. جاري التعديل

ما أقصده هو أنني فتحت جدول الشفوي وأريد توزيع طلاب الصف السادس بالمدرسة رقم 40 (الإجمالي الموجود هو 268 طالب) والذين تم تقسيمهم في جدول الشفوي على 13 دفعة كما في الصورة فسيكون التوزيع الدفعة الأولى 70 صباحي تم الحصول عليهم من (دفعة 1 / دفعة 2 / دفعة 3 / دفعة 4) الدفعة الثانية 60 مسائي تم الحصول عليهم من (باقي دفعة 4 / دفعة 5 / دفعة 6) الدفعة الثالثة 70 صباحي تم الحصول عليهم من (باقي دفعة 6 / دفعة 7 / دفعة 8 / دفعة 9 / دفعة 10) الدفعة الرابعة 60 مسائي تم الحصول عليهم من (باقي دفعة 10 / دفعة 11 / دفعة 12) الدفعة الخامسة 8 (المتبقيين من الصف السادس) صباحي تم الحصول عليهم من (باقي دفعة 12 / دفعة 13) مع خالص تقديري

بحاجة الى توضيح أكثر ، حتى أوجه التعديل الصحيح .

الله الله الله أستاذنا الكبير التوزيع أكثر من رائع وسليم 100 % هي ملاحظة صغيرة جدا جدا وهي أن حقل Noot أو الدفعات .. مطلوب به أن يسجل فيه فقط لا غير الدفعات التي كونت العدد 70 في الصباحي أو الدفعات التي كونت العدد 60 في المسائي وعند ترحيل باقي دفعة (من مجموعة لمجموعة) يتم ذكرها في قرين كل من المجموعتين والف شكر لسعادتك وسلمت يمينك ؛؛؛

كيف احدد اذا كان للمعلم لجنة تصحيح هل كتابة correction1 Correction2 Correction3 بهذا الترتيب

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

اللهم اشفي كل مريض عاجل غير اجل

Up

ادن لنجرب طريقة أخرى Option Explicit Sub Testxlsb() Dim xPath As String, n As Double Dim startTime As Double, xList As String Dim sCount As Long, confirm As VbMsgBoxResult xPath = "D:\" xList = "" With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual startTime = Timer tmps xPath, xList If xList = "" Then MsgBox "لم يتم العثور على أي ملفات بامتداد xlsb في " & xPath Else sCount = UBound(Split(Trim(xList), vbCrLf)) confirm = MsgBox("تم العثور على " & sCount & " ملف بامتداد xlsb " & vbCrLf & _ "هل تريد حدفها ونقلها إلى مجلد الملفات المحدوفة ؟", vbYesNo + vbQuestion) If confirm = vbYes Then tbl xPath, xList Snames xList MsgBox "تم الحذف وحفظ أسماء الملفات في C:\الملفات المحدوفة\filName.txt" Else MsgBox "تم إلغاء العملية لم يتم حذف أي ملفات" End If End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With n = Timer - startTime MsgBox "تم تنفيذ العملية في: " & Format(n, "0.00") & " ثانية" End Sub Sub tmps(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 If Not Folder Is Nothing Then On Error Resume Next For Each file In Folder.Files If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then xList = xList & file.Path & vbCrLf End If End If Next On Error GoTo 0 On Error Resume Next For Each sFiles In Folder.sFiless tmps sFiles.Path, xList Next On Error GoTo 0 End If End Sub Sub tbl(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Dim CntFile As String, r As String, ky As Integer CntFile = "C:\الملفات المحدوفة\DeletedXLSB\" Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists("C:\الملفات المحدوفة\") Then fso.CreateFolder ("C:\الملفات المحدوفة\") If Not fso.FolderExists(CntFile) Then fso.CreateFolder (CntFile) On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 On Error Resume Next For Each file In Folder.Files If Err.Number = 0 Then If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then r = CntFile & fso.GetFileName(file.Path) ky = 1 While fso.FileExists(r) r = CntFile & "Copy_" & ky & "_" & fso.GetFileName(file.Path) ky = ky + 1 Wend file.Move r End If End If End If Err.Clear Next For Each sFiles In Folder.sFiless tbl sFiles.Path, xList Next On Error GoTo 0 End Sub Sub Snames(xList As String) Dim fileNum As Integer fileNum = FreeFile On Error Resume Next Open "C:\الملفات المحدوفة\filName.txt" For Output As #fileNum Print #fileNum, xList Close #fileNum On Error GoTo 0 End Sub TEST2.xlsm

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

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

شكرا جزيلا أخي الفاضل وبارك الله فيك وأكثر الله من أمثالك

وعليكم السلام ورحمة الله تعالى وبركاته جرب الكود التالي اذا ظهر خطا بالكود ربما تحتاج تشغيل تطبيق اكسل كمسؤول Sub DeleteXLSBFromDriveD() Dim folderPath As String folderPath = "D:\" Call DeleteXLSBRecursive(folderPath) MsgBox "تم حذف جميع ملفات .xlsb من الدرايف D (حذف).", vbInformation End Sub Sub DeleteXLSBRecursive(folderPath As String) Dim fs As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fs = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set folder = fs.GetFolder(folderPath) If folder Is Nothing Then Debug.Print "Cannot access folder: " & folderPath Exit Sub End If On Error GoTo 0 On Error Resume Next Dim fileCount As Long fileCount = folder.Files.Count If Err.Number <> 0 Then Debug.Print "Error accessing files in: " & folderPath & " - " & Err.Description Err.Clear On Error GoTo 0 Exit Sub End If On Error GoTo 0 If fileCount > 0 Then For Each file In folder.Files On Error Resume Next If LCase(fs.GetExtensionName(file.Name)) = "xlsb" Then SetAttr file.Path, vbNormal Kill file.Path If Err.Number <> 0 Then Debug.Print "Failed to delete: " & file.Path & " - Error: " & Err.Description Err.Clear End If End If On Error GoTo 0 Next file End If For Each subFolder In folder.SubFolders DeleteXLSBRecursive subFolder.Path Next subFolder End Sub

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

تفضل Data15.rar

أخي أحمد ، جرب هذا التعديل الجديد من حيث الدقة والتوافق بين الشفهي واللياقة ؛ حيث تم اضافة حقلين في جدول اللياقة ( رقم الصف ، وملاحظات ) في المرفق التالي :- فكرة توزيع تلقائي لمستويين (3).mdb

هل يمكن أن ترفق لي الملف

وعليكم السلام هنا امثلة اخرى لضرورة تنسيق كتابة الكود

كود تصدير pdf وليس طباعة لجميع الجداول مرة واحدة وبملف واحد وعددها 17 جدول جدول.xlsm

كل التقدير كل التقدير لسعادتك وعليكم السلام ورحمة الله وبركاته أكرمك وأعزك الله أستاذنا الكبير وكل التقدير والشكر لسعادتك .. بالنسبة لجميع التوصيفات التي أضفتها سعادتك .. تماما بالضبط كما أشرت حضرتك استثناءين فقط في 8 - يتم التوزيع من تاريخ معين سيتم تحديده .. نعم بالفعل (سيتم تحديد تاريخ مسبق للياقة). 9 - الترقيم Magmoaa_Leyaka سيبدأ من 1 لكل مجموعات تخص الصف الدراسي الواحد (بكل مدرسة) يعني الصف الأول في مدرسة الفاروق .. نبدا المجموعات 1 ثم 2 ثم 3 يعني الصف الرابع في مدرسة عمر بن الخطاب .. نبدا المجموعات 1 ثم 2 ثم 3 وهكذا ** لا يوجد أي داعي لربط توزيع الياقة بالشفوي .. واذا اضطررت للربط .. فسيكون سهلا إن شاء الله حيث أن جدول اللياقة موضح به (المدرسة والصف) ** هل نراعي توزيع اللياقة حسب المدرسة أو الصف أو نوزعهم ككتلة واحدة فقط حسب ترتيب الشفوي ؟ التوزيع سيكون (كل دفعات الشفوي بصف معين) سيتم التعامل معها لإنتاج مجموعات اللياقة (70 أو 60) والباقي يرحل للمجموعة التالية في الياقة. يعني الصف الواحد في توزيع الشفوي .. والذي تم تقسيمه لدفعات .. سيتم التعامل مع الدفعات لإنتاج مجموعات اللياقة. طلب أخير .. هل ممكن فتح حقل ينوه فيه إلى الدفعات التي تم توزيعها في لإنتاج مجموعة اللياقة يعني مثلا لو المجموعة الصباحية في الياقة تكونت من (دفعة 1 + دفعة 2 + دفعة 3 + جزء من دفعة 4) هل ممكن كتابة هذه الدفعات في حقل مستقل بهذا الشكل (دفعة 1 / دفعة 2 / دفعة 3 / دفعة 4) ولا يسعني إلا تقديم كل التقدير والشكر لسعادتك والله على هذا الدعم وهذا التألق.

بالنسبة للعربية انظر الصورة لتعديل اسماء التسمية التوضيحية للحقول بالنسبة للعدالة طبعا تقريبية اضف الحقل SupervisionCount في الجدول Teachers نمواصفت ( رقم - القيمة الافتراضية 0 ) ثم استخدم الكود التالي في زر التوزيع Dim db As DAO.Database Dim rsA As DAO.Recordset, rsB As DAO.Recordset Dim rsRooms As DAO.Recordset, rsDays As DAO.Recordset, rsTarget As DAO.Recordset Dim supervisionDate As Date, roomName As String Set db = CurrentDb() ' ? تمهيد: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" Set rsDays = db.OpenRecordset("SELECT * FROM SupervisionDays ORDER BY SupervisionDate", dbOpenDynaset) Set rsRooms = db.OpenRecordset("SELECT * FROM ExamRooms ORDER BY RoomName", dbOpenDynaset) Set rsTarget = db.OpenRecordset("TeacherAssignment") ' ? تحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long totalSupervisionsNeeded = DCount("*", "SupervisionDays") * DCount("*", "ExamRooms") availableA = DCount("*", "Teachers", "TeacherCategory = 'A' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("عدد المعلمين المتاحين قد لا يكون كافياً لتغطية جميع القاعات في جميع الأيام." & vbCrLf & _ "هل ترغب في المتابعة مع ذلك؟", vbYesNo + vbQuestion, "تأكيد التوزيع") If response = vbNo Then MsgBox "تم إلغاء عملية التوزيع بناءً على طلب المستخدم.", vbInformation Exit Sub End If End If ' ?? بدء التوزيع Dim usedA As Collection: Set usedA = New Collection Dim usedB As Collection: Set usedB = New Collection Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName ' معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsA.MoveFirst Do While Not rsA.EOF If Not InCollection(usedA, rsA!TeacherName & "#" & supervisionDate) And (IsNull(rsA!ExamDate) Or rsA!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsA!TeacherName rsTarget!TeacherCategory = rsA!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedA.Add rsA!TeacherName, rsA!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsA!TeacherName & "'" Exit Do End If rsA.MoveNext Loop ' معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsB.MoveFirst Do While Not rsB.EOF If Not InCollection(usedB, rsB!TeacherName & "#" & supervisionDate) And (IsNull(rsB!ExamDate) Or rsB!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsB!TeacherName rsTarget!TeacherCategory = rsB!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedB.Add rsB!TeacherName, rsB!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsB!TeacherName & "'" Exit Do End If rsB.MoveNext Loop rsRooms.MoveNext Loop rsDays.MoveNext Loop rsTarget.Close: rsA.Close: rsB.Close: rsRooms.Close: rsDays.Close Set rsTarget = Nothing: Set rsA = Nothing: Set rsB = Nothing Set rsRooms = Nothing: Set rsDays = Nothing: Set db = Nothing MsgBox "تم توزيع المعلمين بعد تحقق العدالة وشروط الاستبعاد!"

وعليكم السلام ورحمة الله تعالى وبركاته هل تقصد حدف الملفات ادا كان كدالك فالكود قد يستغرق وقتا طويلا وقد يجمد Excel أحيانا خاصة عند البحث داخل درايف كامل (مثلD) يحتوي على آلاف الملفات والمجلدات الأفضل تحديد مجلد معين داخل بارتيشن معين سيكون افضل واسرع

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

الآن جميع طلاب الشفهي سيخضعون للياقة ، صحيح ؟ أي لا يوجد استثناءات !! يتم توزيعهم على جلستين (صباحي / مسائي) بنفس مبدأ الشفوي . القدرة الاستيعابية للياقة تختلف : صباحي = 70 طالب مسائي = 60 طالب يتم أخذ الطلاب من جدول Tb_Tawze_Shafawe بترتيب ظهورهم ( حسب Magmoaa ) . يتم حفظ التوزيع في جدول Tb_Tawze_Leyaka . للتأكيد . يوجد حقل From_Mag_Shafawe سنستخدمه لتوثيق أن المجموعة ( أو جزء منها ) جاءت من مجموعة شفوي رقم كذا . يتم تجاهل يوم الجمعة كالعادة من التوزيع . يتم التوزيع من تاريخ معين سيتم تحديده ( أخبرني هذه النقطة بوضوح ) . الترقيم Magmoaa_Leyaka سيبدأ من 1 ويستمر بترتيب التوزيع دون إعادة الترقيم . هل هناك أي استثناءات أو شروط إضافية لم تذكرها بعد ❔ على سبيل المثال :- هل نحتاج ربط اللياقة بتاريخ الشفوي محدد ❓ هل نراعي توزيع اللياقة حسب المدرسة أو الصف أو نوزعهم ككتلة واحدة فقط حسب ترتيب الشفوي ❓