اضافة البيانات في أكثر من شيت في ملف اكسل

[عفرنس]

أيضا عند اختيار الشعبة رقم 2 يضيف طلابها في شيت رقم 2 والمفترض يضيفهم في شيت رقم 4 ، وكذلك شعبة 3 المفترض يضيفهم في شيت رقم 6 وكذلك شعبة 4 المفترض يضيفهم في شيت رقم 8 

[Barna]

هل اخترت من النموذج 

الصف

المادة

المعلم

[عفرنس]

1 دقيقه مضت, Barna said:

هل اخترت من النموذج 

الصف

المادة

المعلم

إي نعم 

[عفرنس]

.

 

 

 

تم تعديل ديسمبر 20, 2020 بواسطه عفرنس

[Barna]

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

 

[عفرنس]

7 دقائق مضت, Barna said:

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

 

ممتاز لكن ليش كرر اسم الطالب ؟؟ 

الان, عفرنس said:

ممتاز لكن ليش كرر اسم الطالب ؟؟ 

يعني جاء باسم الطالب 7 مرات في الشيت رقم 2 بناء على عدد المواد التي يدرسها .. 

[عفرنس]

14 دقائق مضت, Barna said:

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

 

عندما أرحل البيانات إلى القالب لا يضيفها إلا في شيت 2 فقط . لعلك ترفق لي البرنامج بالكود الجديد . فلعلي أخطأت في نسخ الكود .. 

[Barna]

ابحث عن هذا الكود لديك 

واستبدله بهذا ...

   ("SELECT STUDENT.STUACDID, STUDENT.STUNAME FROM STUDENT WHERE (((STUDENT.المادة)='" & text3 & "') AND ((STUDENT.الشعبة)='" & RS_SECTIONS![الشعبة] & "')) ORDER BY STUDENT.STUNAME;")

 

[أبو إبراهيم الغامدي]

48 دقائق مضت, عفرنس said:

يعني جاء باسم الطالب 7 مرات في الشيت رقم 2 بناء على عدد المواد التي يدرسها ..

أعتذر عن هذا الخطأ.. أ. @Barna قام بالواجب

[عفرنس]

7 دقائق مضت, Barna said:

ابحث عن هذا الكود لديك 

واستبدله بهذا ...

   ("SELECT STUDENT.STUACDID, STUDENT.STUNAME FROM STUDENT WHERE (((STUDENT.المادة)='" & text3 & "') AND ((STUDENT.الشعبة)='" & RS_SECTIONS![الشعبة] & "')) ORDER BY STUDENT.STUNAME;")

 

أحسنت الان ضبط عدم تكرار الأسماء .. 

لكن ما زال عندي مشكلة عدم وضع الشعب في الشيت المحدد لكل شعبة .. 

1 دقيقه مضت, أبو إبراهيم الغامدي said:

أعتذر عن هذا الخطأ.. أ. @Barna قام بالواجب

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

لكن يبقى لدي مشكلة عدم وضع شعبة 2 في شيت 4 وشعبة 3 في شيت 6 وشعبة 4 في شيت 8 

لا أدري أين الخلل عندي . 

 

[Barna]

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

 

تم تعديل ديسمبر 20, 2020 بواسطه Barna

[عفرنس]

الان, Barna said:

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

 

هل في اعتقادك نوع اصدار أكسس ؟؟ 

اللي عندي 2016

الان, عفرنس said:

هل في اعتقادك نوع اصدار أكسس ؟؟ 

اللي عندي 2016

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

2 دقائق مضت, عفرنس said:

هل في اعتقادك نوع اصدار أكسس ؟؟ 

اللي عندي 2016

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

هذا قالب الرياضيات الذي أعمل عليه .. @Barna

رياضيات .xlsm

[عفرنس]

منذ ساعه, عفرنس said:

عندما أرحل البيانات إلى القالب لا يضيفها إلا في شيت 2 فقط . لعلك ترفق لي البرنامج بالكود الجديد . فلعلي أخطأت في نسخ الكود .. 

@kanory 

هلّا مررت بنا 

38 دقائق مضت, Barna said:

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

 

..

[عفرنس]

المشكلة أخي @Barna @أبو إبراهيم الغامدي تكمن هنا .

[أبو إبراهيم الغامدي]

16 دقائق مضت, عفرنس said:

المشكلة أخي @Barna @أبو إبراهيم الغامدي تكمن هنا .

أرجو أن تتفهم أنه في هذه المرحلة لا يمكن اختيار شعبة أو شعب بعينها! يجب أن تكون الشعب متسلسة.

لا تقم باختيار قيمة في مربع الشعبة!

 

[kanory]

23 دقائق مضت, عفرنس said:

المشكلة أخي @Barna @أبو إبراهيم الغامدي تكمن هنا .

الكود ليس ليه مشكلة لاحظ هذا 

objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS
    SHEET% = SHEET% + 2

 

[عفرنس]

8 دقائق مضت, أبو إبراهيم الغامدي said:

أرجو أن تتفهم أنه في هذه المرحلة لا يمكن اختيار شعبة أو شعب بعينها! يجب أن تكون الشعب متسلسة.

لا تقم باختيار قيمة في مربع الشعبة!

 

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

إذا كيف أعمل ؟؟ فأنا لم أفهم ما تفضلت به . 

[أبو إبراهيم الغامدي]

لحل هذه الاشكالية وتمكين اختيار شعب بعينها يلزم تبديل الشفرة يالتالي

Public Sub barnaExcelFile(sXlsFile As String)
  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%
  
  Do Until RS_SECTIONS.EOF
    SHEET% = Choose(CInt(RS_SECTIONS![الشعبة]), 2, 4, 6, 8, 2, 4, 6, 8)
    '-- إيجاد أسماء الطلاب بناء على الشعبة
    Set RS_STUDENTS = CurrentDb.OpenRecordset _
    ("SELECT STUACDID,STUNAME FROM STUDENT " _
    & "WHERE (Student.المادة='" & Me.text3 & "') AND (Student.الشعبة='" & 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
        
    '-- الانتقال إلى الشعبة التالية
    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 "تم تصديرالبيانات بنجاح"
End Sub

 

Active Teacher.zip

[أبو إبراهيم الغامدي]

8 ساعات مضت, عفرنس said:

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

إذا كيف أعمل ؟؟ فأنا لم أفهم ما تفضلت به . 

لو رجعت إلى مشاركي وإلى قاعدة البيانات المثال التي أرفقتها مع التعديلات التي أجريتها لوجدت أني قد أجريت تعديل على النموذج ونبهت على السبب الذي أوجب هذا التعديل!

وهذا يعني أنك تستخف بي!

[عفرنس]

18 دقائق مضت, أبو إبراهيم الغامدي said:

وهذا يعني أنك تستخف بي!

أخي @أبو إبراهيم الغامدي 

والذي رفع السماء بلا عمد ما طرأ هذا الكلام على بالي .. غفر الله لي ولك .. 

* الأمر الثاني فالنسخة التي أعمل عليها فعلا ليست التي عملتها أنت .. وهذا ربما هو الذي أشكل علي .. 

* وإلى هنا سأتوقف .. 

* وأسأل الله أن يغفر لي ولك .. 

[أبو إبراهيم الغامدي]

أهلا @عفرنس 

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

أرجو بعد الانتهاء من الإجراء أعلاه أن تجرب اختيار شعب عشوائية وتصدرها إلى أكسل لترى النتيجة...

لا تنسخ الشفرة .. انسخ النموذج بالكامل..

[abouelhassan]

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

اسف للتدخل مع الشكر 

[أبو إبراهيم الغامدي]

المرفق السابق به خطأ.. أعتذر!

Active Teacher.zip

[Barna]

11 ساعات مضت, عفرنس said:

هل في اعتقادك نوع اصدار أكسس ؟؟ 

اللي عندي 2016

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

هذا قالب الرياضيات الذي أعمل عليه .. @Barna

رياضيات .xlsm 421.81 kB · 2 downloads

هذا القالب تختلف عن القالب الاساسي الذي تم العمل عليه ..... انظر

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

    objWorkbook.Sheets(SHEET%).range("c5").CopyFromRecordset RS_STUDENTS

الاستبدال يكون بهذا الشكل ولاحظ موقع لصق البيانات اصبح حسب ملفك الجديد C8

    objWorkbook.Sheets(SHEET%).range("c8").CopyFromRecordset RS_STUDENTS

فقط هذا كل شيئ .... ملاحظة يجب ان تكون جميع ملفات الاكسل ( احياء - فيزياء - رياضيات وغيرها بنفس تصميم ملف الرياضيات الجديد اقصد بذلك موقع لصق البيانات اي C8 

ارجو اكون وفقت في الشرح !!!

[عفرنس]

12 ساعات مضت, أبو إبراهيم الغامدي said:

المرفق السابق به خطأ.. أعتذر!

Active Teacher.zip 573.24 kB · 1 download

شكر الله لك أخي الكريم @أبو إبراهيم الغامدي 

الأمور تسير إلى خير .. 🌹🌹