Barna

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

وفيك بارك ... حياك الله

تفضل .... النماذج.accdb

مشاركة مع اخي الاستاذ @ناقل تفضل -------->>>>>> can.accdb

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

تاكد اخي من ملف المعلمين لا يعمل ثم تابع وناقش هنا موضوع للاستاذ @أبو إبراهيم الغامدي

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

فكر في هذا !!!! لربط جداول المعلمين والطلاب ؟؟؟؟

هذا القالب تختلف عن القالب الاساسي الذي تم العمل عليه ..... انظر اذا كل ماهو عليك هو تعديل هذا السطر لديك لاحظ بارك الله فيك موقع لصق البيانات كان C5 objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS الاستبدال يكون بهذا الشكل ولاحظ موقع لصق البيانات اصبح حسب ملفك الجديد C8 objWorkbook.Sheets(SHEET%).range("c8").CopyFromRecordset RS_STUDENTS فقط هذا كل شيئ .... ملاحظة يجب ان تكون جميع ملفات الاكسل ( احياء - فيزياء - رياضيات وغيرها بنفس تصميم ملف الرياضيات الجديد اقصد بذلك موقع لصق البيانات اي C8 ارجو اكون وفقت في الشرح !!!

الحقيقة لا ادري ولكن الكود يعمل طبيعي لدي

ابحث عن هذا الكود لديك واستبدله بهذا ... ("SELECT STUDENT.STUACDID, STUDENT.STUNAME FROM STUDENT WHERE (((STUDENT.المادة)='" & text3 & "') AND ((STUDENT.الشعبة)='" & RS_SECTIONS![الشعبة] & "')) ORDER BY STUDENT.STUNAME;")

الكود شغال في الملف .... انظر ...

هل اخترت من النموذج الصف المادة المعلم

تم التوصل الى المطلوب وهذا هو التعديل .... Dim fldrname As String Dim fldrpath As String Dim LExcelOriginal As String Dim LExcelCopyOf As String Dim WHERE$ '.. اللاحقة $ تعني أن المتغير نصي Dim RS_SECTIONS As DAO.Recordset Dim RS_STUDENTS As DAO.Recordset Dim fso As Object Dim objExcel As Object Dim objWorkbook As Object '-- إنشاء مجلد للمقرر Set fso = CreateObject("scripting.filesystemobject") fldrname = Me.[text3] fldrpath = CurrentProject.Path & "\السجل الالكتروني\" & fldrname If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) End If '-- التأكد من توفر البيانات الأولية If Len(Me.text2) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')AND (Student.الشعبة='" & Me.text2 & "')" ElseIf Len(Me.text3) Then WHERE$ = " WHERE (Student.المادة='" & Me.text3 & "')" Else MsgBox "بينات التصدير غير مكتملة" Exit Sub End If '-- إيجاد الشعب Set RS_SECTIONS = CurrentDb.OpenRecordset _ ("SELECT DISTINCT [الشعبة] FROM Student " & WHERE$ & "ORDER BY [الشعبة]") If RS_SECTIONS.RecordCount = 0 Then MsgBox "لا توجد بيانات لتصديرها" Exit Sub End If '-- نسخ قالب مصنف البيانات إلى مجلد المقرر LExcelOriginal = sXlsFile LExcelCopyOf = CurrentProject.Path & "\السجل الالكتروني\" & fldrname & "\" & Me.[text3] & "_.xlsm" Call FileCopy(LExcelOriginal, LExcelCopyOf) Set objExcel = CreateObject("Excel.Application") Set objWorkbook = objExcel.Workbooks.Open(LExcelCopyOf) '-- تدوير البيانات بناء على الشعب Dim SHEET% SHEET% = 2 Do Until RS_SECTIONS.EOF '-- إيجاد أسماء الطلاب بناء على الشعبة Set RS_STUDENTS = CurrentDb.OpenRecordset _ ("SELECT STUACDID,STUNAME FROM STUDENT WHERE [الشعبة]='" & RS_SECTIONS![الشعبة] & "' ORDER BY STUNAME") ' تعديل اسم صفحات الاكسل حسب اسماء الاستعلامات objWorkbook.Sheets(SHEET%).Name = RS_SECTIONS![الشعبة] '-- بيانات الترويسة objWorkbook.Sheets(SHEET%).range("B1").Value = _ "اسماء طلاب الصف " & "(" & Me.[text1] & ")" _ & " -- " & "(" & RS_SECTIONS![الشعبة] & ")" _ & " المادة " & "(" & Me.[text3] & ")" _ & " معلم المادة / " & "(" & Me.[text4] & ")" '-- بيانات الطلاب objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS SHEET% = SHEET% + 2 '-- الانتقال إلى الشعبة التالية RS_SECTIONS.MoveNext Loop '-- حفظ البيانات objExcel.DisplayAlerts = True objWorkbook.Close SaveChanges:=True '-- إغلاق المصادر objExcel.Quit Set objWorkbook = Nothing Set objExcel = Nothing Set RS_SECTIONS = Nothing Set RS_STUDENTS = Nothing ' VBA.Shell "Explorer.exe " & Chr(34) & LExcelCopyOf & Chr(34), vbNormalFocus"هذا السطر لفتح ملف الاكسل بعد التصدير" ' DoCmd.DeleteObject acTable, "temp" MsgBox "تم تصديرالبيانات بنجاح" تم اضافة هذه الشيفرية .... ' تعديل اسم صفحات الاكسل حسب اسماء الاستعلامات objWorkbook.Sheets(SHEET%).Name = RS_SECTIONS![الشعبة]

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

اخي @أبو إبراهيم الغامدي هل يمكن تعديل الشيفرة السابقة ليكون اسم الشيت هو اسم الشعبة المصدرة لتلك الورقة ...... بارك الله فيك ..

ممكن توضيح اكثر ... ماهو هذا الكود

اذا كان كلامك على النموذج ممكن تطبق كما يلي مع تعديل المسميات ::: Select Case Nz(e2) Case Is >= 90 [r2] = "ممتاز" Case Is >= 80 [r2] = "جيد جدا" Case Is >= 70 [r2] = "جيد" Case Is >= 50 [r2] = "مقبول" Case Is < 50 [r2] = "ضعيف" End Select اذا كان استعلام ممكنقاعدة IF بهذه الصورة new: IIf([Retba]="ملازم";"ملازم اول";IIf([Retba]="ملازم اول";"نقيب";IIf([Retba]="نقيب";"رائد")))

اجعل الامر في النموذج الفرعي Public Sub ثم استدعها من الرئيسي Forms!F1.f2.Form.اسم Public Sub

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

حياك الله اخي محمد اهلابك .... جزاك الله خيرا

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

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

شوف كدا ... ممكن ... اذا هو ما تريد اكمل الاخير .... Users.accdb

هل حاولت اخي الكريم Select Case .....