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

هذا البرنامج هو لحساب المواريث والوصايا بالاكسل يمكن تشغيله بالنقال الذكى ..او الحاسوب نسخة 2024 اعداد الفرضى المهندس خالد الطاهر حدادة عنوان البريد الإلكتروني khaledhadada47@gmail.com ليبيا الفرائض_الربانية_بالجداول_الالكترونية_2024.xlsx

أسأل الله العظيم رب العرش العظيم أن يشفيه شفاء لا يغادر سقما آمين وجميع مرضى المسلمين

تفضل ...... ‏‏NA_2.accdb

اختصاراً لوقتك و وقت الاساتذة ، لم لا تقوم بالافاق الملف .

تفضل أخي بناء على نفس الفكرة السابقة أرفق لك ملف يحتوي على كودين: الكود الأول: إنشاء مجلدات وملفات بصيغة xlsb للتجربة تم تعديل الكود بحيث يمكنك: 1) اختيار البارتيشن الذي تريد إنشاء الملفات فيه 2) تحديد عدد المجلدات التي سيتم إنشاؤها 3) تحديد عدد الملفات داخل كل مجلد حسب حاجتك الكود الثاني: تحويل جميع ملفات xlsb في البارتيشن المحدد الكود يقوم بـالبحث داخل البارتيشن الذي تحدده وتحويل جميع الملفات ذات الامتداد xlsb إلى صيغة أخرى xlsx داخل البارتشن المحدد حتى وإن كانت مخزنة داخل مجلدات فرعية متداخلة Option Explicit Sub Convertfiles() Dim dl As Object, n As String, ky As String Dim files() As String, i As Long, a As Long Dim startTime As Double, confirm As VbMsgBoxResult n = "F:\" ' لا تنسى تعديل إسم البارتيشن بما يناسبك confirm = MsgBox("سيتم تحويل جميع الملفات بصيغة xlsb إلى xlsx" & vbCrLf & _ "هل تريد المتابعة؟", vbYesNo + vbQuestion, n & " " & "محرك الأقراص") If confirm <> vbYes Then Exit Sub Set dl = CreateObject("Scripting.FileSystemObject") startTime = Timer SupApp True ky = tMps(dl, n) If Trim(ky) = "" Then MsgBox "xlsb" & " " & "لم يتم العثور على أي ملفات بصيغة ", vbInformation GoTo Cleanup End If files = Split(ky, vbCrLf) a = 0 For i = LBound(files) To UBound(files) If Trim(files(i)) <> "" Then If CntFiles(Trim(files(i)), dl) Then a = a + 1 End If End If Next i MsgBox "تم تحويل" & a & " ملف بنجاح" & vbCrLf & _ "استغرق التنفيذ " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Cleanup: SupApp False End Sub Function CntFiles(filePath As String, dl As Object) As Boolean Dim wb As Workbook Dim newPath As String On Error GoTo ClearApp Set wb = Workbooks.Open(filePath, ReadOnly:=False) newPath = Replace(filePath, ".xlsb", ".xlsx") wb.SaveAs fileName:=newPath, FileFormat:=xlOpenXMLWorkbook wb.Close SaveChanges:=False If dl.FileExists(newPath) Then dl.DeleteFile filePath, True CntFiles = True End If Exit Function ClearApp: CntFiles = False If Not wb Is Nothing Then wb.Close SaveChanges:=False End Function Function tMps(dl As Object, n As String) As String Dim root As Object, list As Collection, item As Variant, result As String On Error Resume Next Set root = dl.GetFolder(n) If root Is Nothing Then Exit Function On Error GoTo 0 Set list = New Collection Call ScanFiles(dl, root, list) For Each item In list result = result & item & vbCrLf Next item tMps = result End Function Sub ScanFiles(dl As Object, folder As Object, ByRef list As Collection) Dim file As Object, subFolder As Object, fName As String fName = LCase(folder.Path) If InStr(fName, "$recycle.bin") > 0 Then Exit Sub If InStr(fName, "system volume information") > 0 Then Exit Sub For Each file In folder.files If LCase(dl.GetExtensionName(file.Name)) = "xlsb" Then list.Add file.Path End If Next For Each subFolder In folder.SubFolders ScanFiles dl, subFolder, list Next End Sub TEST4.xlsm

الامر بيدك ان اردت مساعدتنا ، وذلك بإرفاق الملف الذي يعمل.

تم فحص الملف لدي انظر .............. معطوب

جزاكم الله كل خير ونفع بكم ورزقكم من حيث لا تحتسبون

تفضل استاذ @Noon Ali محاولتي حسب مافهمت التعديل بالمرفق حسب طلبك . ووافني بالرد . databasebalance-111.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يناسبك Option Explicit Sub FilterByNames() Dim WS As Worksheet, arr(), i&, n&, filterRange As Range Set WS = Sheets("Sheet1") If WS.AutoFilterMode Then WS.AutoFilterMode = False n = WS.Cells(WS.Rows.Count, "I").End(xlUp).Row If n < 2 Then Exit Sub ReDim arr(1 To n - 1) For i = 2 To n arr(i - 1) = WS.Cells(i, "I").Value Next i Set filterRange = WS.Range("B6").CurrentRegion With filterRange .AutoFilter Field:=2, Criteria1:=arr, Operator:=xlFilterValues End With End Sub

تم تعديل الكود ............................ 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 Dim teacherAssignedA As Boolean, teacherAssignedB As Boolean Dim dayKey As String Dim safeName As String Dim teacherName As String On Error GoTo ErrorHandler Set db = CurrentDb() ' 1. التهيئة: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" ' 2. التحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long Dim daysCount As Long, roomsCount As Long daysCount = DCount("*", "SupervisionDays") roomsCount = DCount("*", "ExamRooms") totalSupervisionsNeeded = daysCount * roomsCount ' معلم A ومعلم B لكل قاعة ' حساب المعلمين المتاحين مع مراعاة جميع شروط الاستثناء 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 & _ "المطلوب: " & totalSupervisionsNeeded & " معلم A و " & totalSupervisionsNeeded & " معلم B" & vbCrLf & _ "المتاح: " & availableA & " معلم A و " & availableB & " معلم B" & vbCrLf & _ "هل تريد المتابعة مع وضع 'غير مغطاة' للقاعات غير المكتملة؟", _ vbYesNo + vbExclamation, "تنبيه") If response = vbNo Then MsgBox "تم إلغاء التوزيع بناءً على طلبك.", vbInformation Exit Sub End If End If ' 3. بدء عملية التوزيع 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 dailyTeachers As Object Set dailyTeachers = CreateObject("Scripting.Dictionary") ' حلقة على كل الأيام Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate ' تهيئة القاموس لهذا اليوم فقط (ليسمح بالتكرار في الأيام الأخرى) dailyTeachers.RemoveAll ' حلقة على كل القاعات rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName teacherAssignedA = False teacherAssignedB = False ' تعيين معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '') " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsA.EOF Then rsA.MoveFirst Do Until rsA.EOF Or teacherAssignedA teacherName = rsA![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم A rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedA = True End If rsA.MoveNext Loop End If rsA.Close ' إذا لم يتم تعيين معلم A، تسجيل "غير مغطاة" If Not teacherAssignedA Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If ' تعيين معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '') " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsB.EOF Then rsB.MoveFirst Do Until rsB.EOF Or teacherAssignedB teacherName = rsB![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم B rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedB = True End If rsB.MoveNext Loop End If rsB.Close ' إذا لم يتم تعيين معلم B، تسجيل "غير مغطاة" If Not teacherAssignedB Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If rsRooms.MoveNext Loop rsDays.MoveNext Loop ' 4. التنظيف وإغلاق الموارد rsTarget.Close rsRooms.Close rsDays.Close Set rsTarget = Nothing Set rsRooms = Nothing Set rsDays = Nothing Set rsA = Nothing Set rsB = Nothing Set db = Nothing Set dailyTeachers = Nothing MsgBox "تم الانتهاء من التوزيع بنجاح!" & vbCrLf & _ "تم تعيين معلم A ومعلم B لكل قاعة" & vbCrLf & _ "مع مراعاة الشروط التالية:" & vbCrLf & _ "- عدم تكرار المعلم في نفس اليوم" & vbCrLf & _ "- السماح بتكرار المعلم في أيام مختلفة" & vbCrLf & _ "- استثناء المعلمين الذين لديهم اختبار في نفس اليوم" & vbCrLf & _ "- استثناء المعلمين في لجان التصحيح" & vbCrLf & _ "- العدالة في التوزيع حسب عدد المراقبات السابقة", _ vbInformation, "إنجاز" Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء التنفيذ: " & vbCrLf & _ "رقم الخطأ: " & Err.Number & vbCrLf & _ "الوصف: " & Err.Description & vbCrLf & _ "في الإجراء: " & Erl, vbCritical, "خطأ" Resume Next اكتب اي عبارة حتى لو رقم المهم الا يكون الحقل فارغ ......

اللهم الشفاءالعاجل ... والسلامة الدائمة ... بحق اسمك الاعظم ونبيك المكرم ...

أظن أن الأمر ليس بالصعب يمكننا تعديل الكود ليتناسب مع طلبك بحيث يقوم بحدف الملفات سواءا بداخل البارتيشن المحدد مباشرة أو بداخل الملفات الفرعية بما أنه من الصعب تجربة الكود على الملفات الخاصة بي قمت بإنشاء بارتيشن إظافي بإسم F فقط للتجربة يمكنك تغييره بداخل الكود على حسب احتياجاتك مع إظافة كود لإنشاء ملفات بصيغة XLSB للتجربة عليها كما في المثال التالي TEST3.xlsm

وعليكم السلام ورحمة الله وبركاته .. أهلا بأشقائنا في السودان الحبيب ، وبمشاركتك الأولى نرحب بك معنا في عالمنا الصغير .. باعتقادي ومن وجهة نظري ( الغير ملزمة طبعاً ) أن احتساب الرصيد التراكمي له عدة أشكال للحصول عليه ، فمثلاً في أحد نشاريعي القديمة كنت قد توجهت الى اضافة حقل "الرصيد الحالي" لكل عميل بحيث يبدأ من 0 ، ويتم تحديثه بالقيمة الجديدة حسب نوع الحركة ( لنفترض = سحب أو إيداع ) وطبعاً سيكون الأمر مشروطاً برقم العميل الفريد والغير مكرر . وعليه فملاحظاتي في ملفك المرفق هي :- في الجدول Bill_info ، ولنفترض CustomerID = 1 له 5 حركات ( منها 2 مدين ، و 3 دائن ) فبعد كل حركة إدخال سجل جديد يتم انشاء دالة أو استعلام تحديث بحيث اذا كانت العملية مدين فيتم اضافتها الى الحقل السابق الذي قلنا انه مخصص للرصيد التراكمي ، وان كانت دائن يتم خصمها أو طرحها من رصيده .. وعليه تستطيع تتبع كل حركة بتاريخها و قيمتها ... إلخ . أتمنى أن تكون الفكرة قد وصلت بشكل صحيح و واضح . ومتأكد أنك ستجد الكثير من الأفكار التي يمكن تطبيقها وتنفيذها .

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

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

اللهم امين .. أتم يارب شفاءه على أكمل وجه بالشكل الذى يرضيك يا أكرم الأكرمين واربط على اهله وذويه بالصبر على هذا

اذهب البأس رب الناس، بيدك الشّفاء، ولا كاشف له إلا أنت يا رب العالمين، اللهم لا ملجأ ولا منجا منك إلا إليك، إنك على كل شيء قدير اللهم ألبسه الصحة والعافية عاجلًا غير آجل، يا أرحم الراحمين، اللهم اشفه، اللهم اشفه، اللهم اشفه

إللهم أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقماً، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يارب العالمين اشفى ابن محمد هشام اللهم امين

إلهي أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقماً، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يارب العالمين. - اللهم إنّي أسألك من عظيم لطفك وكرمك وسترك الجميل، أن تشفيه وتمدّه بالصحّة والعافية، لا ملجأ ولا منجا منك إلّا إليك، إنّك على كلّ شيءٍ قدير.

اللهم إنا نسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ عليه بالشفاء العاجل، وألّا تدع فيه جرحاً إلّا داويته، ولا ألماً إلا سكنته، ولا مرضاً إلا شفيته، وألبسه ثوب الصحة والعافية عاجلاً غير آجل، وشافِه وعافِه واعف عنه، واشمله بعطفك ومغفرتك، وتولّه برحمتك يا أرحم الراحمين.

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

بالنسبة للعربية انظر الصورة لتعديل اسماء التسمية التوضيحية للحقول بالنسبة للعدالة طبعا تقريبية اضف الحقل 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 "تم توزيع المعلمين بعد تحقق العدالة وشروط الاستبعاد!"

الأخ الفاضل @kkhalifa1960 والأخ الفاضل @jjafferr جزاكم الله كل الخير على الرد والاهتمام بموضوعي كلتا الاجابتين تؤديان المطلوب اجابة الأخ @kkhalifa1960 فيها بعض التوسعة والاضافات الجيدة مرة أخرى من القلب أصدق عبارات الشكر والإمتنان و جزاكما الله خيرا و ربي يبارك في هذا المنتدى الرائع ان شاء الله