د.كاف يار

ارفق نسخة لكي يتم التعديل عليها

تفضل جرب هذا التعديل بدون عمل جداول مؤقته AdoForm.zip

اخي الكريم لتسهيل عملية التحديث اقترح عليك ان تستعين بــ Google drive بحيث تقوم برفع آخر نسخة من التعديلات الى Google drive و من خلال الكود سيتم تحميل هذه النسخة الى جهاز العميل او المستخدم الآخر و حتى يتم ذلك يجب ان تقوم بإنشاء Module جديد و الصق فيه الكود التالي Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr #Else Private Declare Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownLoadToFileA" (ByVal pCaller As Long, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If Function downloadFile( _ ByVal FileURL As String, _ ByVal FilePath As String) _ As Boolean Const ProcName As String = "downloadFile" On Error GoTo clearError URLDownloadToFile 0, FileURL, FilePath, 0, 0 downloadFile = True ProcExit: Exit Function clearError: Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _ & " " & "Run-time error '" & Err.Number & "':" & vbLf _ & " " & Err.Description Resume ProcExit End Function Sub downloadGoogleDrive(FilePath As String, FileID As String) Const UrlLeft As String = "http://drive.google.com/u/0/uc?id=" Const UrlRight As String = "&export=download" Dim Url As String: Url = UrlLeft & FileID & UrlRight Dim wasDownloaded As Boolean wasDownloaded = downloadFile(Url, FilePath) If wasDownloaded Then MsgBox "Success" Else MsgBox "Fail" End If End Sub Sub NewFileText() On Error Resume Next Dim FileSeveTo As String FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _ Len(CurrentProject.FullName) _ - InStrRev(CurrentProject.FullName, "\")) Dim GoogleFileID As String: GoogleFileID = "1DQqZYciRIs_dcBE6JLeoqiB3zjcq2SpL" Call downloadGoogleDrive(FileSeveTo, GoogleFileID) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim oFile As Object Set oFile = fso.CreateTextFile(CurrentProject.Path & "\UpdateFile.cmd") oFile.WriteLine "@Echo OFF" oFile.WriteLine "SLEEP 3" oFile.WriteLine "copy " & """" & FileSeveTo & """" & " " & """" & CurrentProject.FullName & """" & " /Y" oFile.WriteLine "call " & """" & CurrentProject.FullName & """" oFile.WriteLine "exit" oFile.Close Set fso = Nothing Set oFile = Nothing 'تشغيل ملف النظام Dim RetVal RetVal = Shell(CurrentProject.Path & "\UpdateFile.cmd", 1) Application.CloseCurrentDatabase End Sub و للاستدعاء لتحميل الملف و استبدال النسخة الحالية للمستخدم استخدم الكود التالي في ازرار التحديث او في اي اجراء تستخدمه للتحديث (( لا تنسى وضع مفتاح الملف الذي حصلت عليه من قوقل )) '=========================================================================== Dim GoogleFileID As String: GoogleFileID = "مفتاح الملف من قوقل درايف" '=========================================================================== Dim FileSeveTo As String FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _ Len(CurrentProject.FullName) _ - InStrRev(CurrentProject.FullName, "\")) Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

نصيحة لك الى ان تنتهي المشكلة ارفع ملفاتك على google drive او mediafire او اي موقع خارجي لتحميل الملفات

تفضل هذه المحاولة لكن استفسارك ماهو واضح للأسف Database81.zip

ابشر اتفضل التعديل sa1.3.zip

اتوقعت انهم كلهم واحد راح يكون عندك مجلدين مجلد : ملفات الأفراد مجلد : ملفات المكلفين بنفس الجدول و نفس النموذج اتفضل التعديل sa1.2.zip

هل تقصد مثل هذا DateVal.mdb

ما ذا تقصد بالطرح في التاريخ ؟ (فالتواريخ المراد وضعها فى العمود الجديد تمثل أكبر ناتج طرح للتواريخ) لو اردت حساب مدة بين تاريخين استخدم التالي DateDiff(«interval»; «date1»; «date2») حيث ان interval تعبر عن معيار الحساب مثلا لو اردت حساب عدد الأيام بين تاريخين يكون بالطريقة التالية DateDiff("D"; [date1]; [date2]) و لو اردت حساب عدد الأشهر تكون بالطريقة التالية DateDiff("M"; [date1]; [date2]) و لو اردت حساب عدد السنوات تكون بالطريقة التالية DateDiff("YYYY"; [date1]; [date2]) و لو اردت حساب عدد الأسابيع تكون بالطريقة التالية DateDiff("WW"; [date1]; [date2]) و لو اردت حساب الربع سنوي تكون بالطريقة التالية DateDiff("Q"; [date1]; [date2])

تفضل هذا التعديل لتجاوز الخطأ Public Function importExcel(Tablename As String, FilePath As String) On Error Resume Next Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(FilePath) Set xlWs = xlWb.Worksheets(1) intLine = 2 'سيتم استيراد الصفوف بدء من الصف رقم 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing End Function

العفو اخي الكريم و تحت امرك و الأمر كله لله

لأن نوع العمود رقمي و يأخذ قيمته من جدول العام الدراسي بناء على كود العام نصيحة لك استبدل نوع العمود و اجعله نصي لكي يسهل العمل عليه تفضل هذا التعديل كما تريده تماما بعد تغيير نوع عمود السنة الدراسية school.accdb

تفضل هذا التعديل استبدل المعيار بالتالي IIf([العام الدراسي]=7;8;7) school.accdb

ممتاز ثبتها و جرب الكود استبدل الكود بالتالي Public Function importExcel(Tablename As String, FilePath As String) Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(FilePath) Set xlWs = xlWb.Worksheets(1) intLine = 2 'سيتم استيراد الصفوف بدء من الصف رقم 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing End Function

تفضل التعديل sa1.1.zip

ارفق مثال لكي يتم التعديل عليه او اتبع الطريقة التالية اولا ارفق استدعي المكتبة التالية ثانيا / الصف الكودي التالي في اي مكان داخل المحرر Public Function importExcel(Tablename As String, FilePath As String) Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String varfile = FilePath Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(varfile) Set xlWs = xlWb.Worksheets(1) intLine = 2 'سيتم استيراد الصفوف بدء من الصف رقم 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing End Function و في ازرار استيراد البيانات الصق الكود التالي Dim Addfile As Object: Set Addfile = Application.FileDialog(3) With Addfile: .Filters.Add "All Files", "*.xlsx" If .Show = True Then ' Call importExcel("Table Name", "File Path") Call importExcel("tb1", Trim(.SelectedItems(1))) End if End With

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

تكون بهذا الشكل iif([العام الدراسي]="2021/2022";"2022/2023";"2021/2022")

تفضل هذا التعديل DateVal.mdb

اعمل ملف جديد فيه فقط الجزئية

ارفق مثال لما تريد لكي يتم التعديل عليه

من خلال الاستعلام الخاص بالنموذج الفرعي تستطيع ترتيب الأسماء

تفضل هذا التعديل Filter.accdb

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

تفضل التعديل سيتم انشاء مجلد بإسم (ملفات الأفراد) و سيتم انشاء مجلدات داخل مجلد ( ملفات الأفراد ) برقم الملف و سيتم انشاء مجلدات حسب القائمة داخل كل مجلد برقم الملف بالإسم حسب القائمة sa1.0.zip