اذهب الي المحتوي
أوفيسنا

برنامج لعمل قوائم الفصول 2018


EL_Kashef

الردود الموصى بها

السلام عليكم ورحمة الله وبركاته

بفضل الله تعالى أولا وأخيرا

ثم بمساعدة الأعضاء الكرام لهم جزيل الشكر والعرفان

قمت بعمل ملف أكسيل لكتابة قوائم الفصول المدرسية

  2018 بمناسبة اقتراب العام الدراسى الجديد  

 مع العلم أنى مبتدئ فى الأكسيل

وإليكم شرح بعض خصائصه

الملف يصلح لفرقة واحدة ولكن يمكنك نسخ الملف أكثر من مرة وتعديل أسماء الفصول فبذلك يصلح لأكثر من فرقة

عدد طلاب الفرقة الواحدة 500

عدد الفصول 10 لكل فصل 50 طالب

تتم كتابة البيانات الأساسية مرة واحدة فى البداية ويتم توزيعها تلقائيا على كل الفصول

بعد كتابة بيانات الطلاب تضغط على ترتيب الأسماء أبجديا

فيتم الترتيب كالتالى

الاسم بترتيب الحروف الأبجدية طبعا ثم الإناث أولا وبعد ذلك الذكور

بعد ذلك تضغط على ترحيل البيانات 

فيتم الترحيل حسب الفصل الذى اخترته مسبقا عند كتابة البيانات

يتم استخراج الإحصائيات تلقائيا

كل فصل على حده

والإحصاء العام للفرقة كلها


أكرر يتم حساب الإحصاء بعد ترحيل البيانات

الملف معد للطباعة مسبقا بحيث يكون كل فصل فى ورقة واحدة فقط

طبعا بالنسبة للبيانات المطلوبة

الاسم - النوع - الديانة - الحالة

( دى البيانات اللى بنكتبها عندنا فى القوائم وكل منطقة بتختلف عن التانية طبعا )

باسورد vb

لمن يحب الاطلاع على الأكواد

Reem.2018*

أرجو ابداء الملاحظات للتعديل فى الملف إن أمكن بمساعدتكم طبعا

الملف لا يوجد عليه أى حقوق شخصية أو كلمات سر الا التى كتبتها مسبقا

فهذا العمل خالص لوجه الله

ليستفيد منه الجميع

دعوة صالحة بظهر غيب تكفى

الملف فى المرفقات

للصفوف الإعدادية

وتقبلوا تحياتى

 

 

الصف الأول الإعدادى.rar

الصف الثالث الإعدادى.rar

الصف الثانى الإعدادى.rar

برنامج قوائم الفصول النهائى.rar

رابط هذا التعليق
شارك

رائع التعديل الذي وضعته على الكود

انا بدوري وضعت لك تعديلاً اخر بواسطة الحلقات التكرارية (يمكن استعمالها جيث انه لا خلايا مدمجة)

مرفق الكود (الصف الاعدادي الاول)   (بدون حلقات تكرارية)   يعتمد على Resize 

او الكود الثاني  ***** حلقات تكرارية  

مع اقتراح نسخ احدهما الى بقية المصنفات حيث انه اسرع

Option Explicit

Sub tanslate_data_salim1()
Dim My_Sh As Worksheet
Dim lr1, i, k, m, col, y As Integer
Dim my_rg, cel  As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr1 = Main.Cells(Rows.Count, "c").End(3).Row
Set my_rg = Main.Range("c17:g" & lr1)

For i = 1 To 10
     m = 0
         Set My_Sh = Sheets(i & "")
          My_Sh.Range("d12:g36").ClearContents
          My_Sh.Range("i12:l36").ClearContents
               For k = 17 To lr1
                 Select Case m
                       Case Is < 25
                       		col = m + 12
                       		y = 4
                       Case Else
                      		 col = m - 13
                      		 y = 9
                 End Select
                   If Main.Cells(k, "g") = i Then
                          My_Sh.Cells(col, y).Resize(1, 4).Value = Main.Cells(k, 3).Resize(1, 4).Value
                    m = m + 1
                   End If
               Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Option Explicit

Sub tanslate_data_salim()
Dim My_Sh As Worksheet
Dim lr1, i, k, m, x As Integer
Dim my_rg, cel  As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr1 = Main.Cells(Rows.Count, "c").End(3).Row
Set my_rg = Main.Range("c17:g" & lr1)

For i = 1 To 10
m = 0
 Set My_Sh = Sheets(i & "")
  My_Sh.Range("d12:g36").ClearContents
  My_Sh.Range("i12:l36").ClearContents
  For k = 17 To lr1
  '=======================
 Select Case m
  Case Is < 25
    If Main.Cells(k, "g") = i Then
          For x = 0 To 3
              My_Sh.Cells(m + 12, 4).Offset(, x) = Main.Cells(k, 3).Offset(, x)
          Next
              m = m + 1
    End If
  Case Else
      If Main.Cells(k, "g") = i Then
        For x = 0 To 3
            My_Sh.Cells(m - 13, 9).Offset(, x) = Main.Cells(k, 3).Offset(, x)
        Next
            m = m + 1
       End If
  End Select
  Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

 

رابط هذا التعليق
شارك

السيد سليم

شرفنى مرورك وردك الرائع والمشجع

والأروع الأكواد التى أعطيتنى إياها

والتى لولاها ماكنت أكملت هذا الملف

جربت الأكواد وهى بالفعل رائعة

سلمت يداك

تقبل شكرى وتقديرى

  • Like 1
رابط هذا التعليق
شارك

منذ ساعه, EL_Kashef said:

السيد سليم

شرفنى مرورك وردك الرائع والمشجع

والأروع الأكواد التى أعطيتنى إياها

والتى لولاها ماكنت أكملت هذا الملف

جربت الأكواد وهى بالفعل رائعة

سلمت يداك

تقبل شكرى وتقديرى

كود اخر بواسطة Loop

انتبه الى الملاحظات في اسفل الكود

بواسطة هذه المعادلات لا تتأثر الخلايا في حال زيادة صفوف او حذف صفوف (قبل الصف 12)من الورقة

أو اذا تم حذف اي اسم من لائحة الفصل لا يتأثر الترقيم في كلا العامودين

 

اذا كنت قد فهمت الكود اليك هذا المهمة
 تنزيل كود اخر بحيث:

1-يعمل على المتغير I بواسطة Loop (من 1 الى 10)         * عدد الفصول

2-يعمل على المتغير K بواسطة Loop (من 17 الى اخر صف في الورقة Main)       * هذا الخاصية موجودة في الكود المرفق

3- يقوم بترقيم التلاميد بدون معادلات في العامودين I & C  في كل ورقة من ورقات الصفوف

Option Explicit


Sub tanslate_data_salim_loop()
Dim My_Sh As Worksheet
Dim lr1, i, k, m, col, y As Integer
Dim my_rg, cel  As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr1 = Main.Cells(Rows.Count, "c").End(3).Row
Set my_rg = Main.Range("c17:g" & lr1)

For i = 1 To 10
     m = 0
         Set My_Sh = Sheets(i & "")
          My_Sh.Range("d12:g36").ClearContents
          My_Sh.Range("i12:l36").ClearContents
          k = 17
               Do Until k = lr1 + 1 'يمكنك استعمال هذا السطر
'              Do While k <= lr1 'او هذا السطر
                       Select Case m
                       Case Is < 25
                       col = m + 12
                       y = 4
                       Case Else
                       col = m - 13
                       y = 9
                 End Select
                   If Main.Cells(k, "g") = i Then
                          My_Sh.Cells(col, y).Resize(1, 4).Value = Main.Cells(k, 3).Resize(1, 4).Value
                    m = m + 1
                   End If
                   k = k + 1
            Loop
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                               ملاحظات
'  بالنسبة للمعادلات في صفحات الصفوف
'الافضل كتابة هذه المعادلة في الخلية
'C12:
'=IF(D12="","",MAX($C$11:C11)+1)
'ثم اسحب نزولاً


'و هذه المعادلة في الخلية
'I12:
'=IF(I12="","",MAX(C:C)+ROWS($A$1:A1))
     'ثم اسحب نزول
     

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


 

  • Like 3
رابط هذا التعليق
شارك

يعجز لسانى عن الشكر

وعن المتابعة المستمرة لملفى المتواضع

وقد قمت بإضافة تعديل بسيط على الملف

وهو إضافة زر لمسح البيانات جميعها فى صفحة بيانات الطلاب

وكذلك اضافة زر لمسح بيانات الطلاب وذلك فى كل فصل على حدة فى المرفقات

برنامج قوائم الفصول.rar

رابط هذا التعليق
شارك

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

لذلك تداركاً للخطأ يجل علينا وضع سطر في الكود

If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub

ليصيح الكود هكذا

Sub ClearConstantsOnly()
'كود مسح البيانات و الحفاظ على المعادلات
If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub
prompt = "هل حقا تريد مسح كل البيانات!؟"
Command_buttons = vbYesNo + VbMsgBoxRt1Reading
Title = "تحذير. انتبه !!!!"
project = MsgBox(prompt, Command_buttons, Title)
If project = vbYes Then
 On Error Resume Next
 Range("c17:g516").SpecialCells(xlCellTypeConstants).ClearContents
Range("A1").Select
End If
End Sub

 

 

  • Like 3
رابط هذا التعليق
شارك

  • 1 year later...

الف شكر لاهتمام حضرتك جدا وجزاك الله الف خير بس فيه مشكلة بسيطة عند اختيار الفصل من القائمة مبلقيش غير 10 فصول بس ارجو تعديلها ولك جزيل الشكر

وقوائم الفصول عند طباعتها غير منضبطة

تم تعديل بواسطه geme114
اضافة
رابط هذا التعليق
شارك

منذ ساعه, geme114 said:

الف شكر لاهتمام حضرتك جدا وجزاك الله الف خير بس فيه مشكلة بسيطة عند اختيار الفصل من القائمة مبلقيش غير 10 فصول بس ارجو تعديلها ولك جزيل الشكر

وقوائم الفصول عند طباعتها غير منضبطة

بعد اذن الاستاذ علي جزاه الله خيرا

لاحظ التعديل حسب طلبكم

تحياتي

برنامج قوائم الفصول++.xls

تم تعديل بواسطه مصطفى محمود مصطفى
  • Like 1
رابط هذا التعليق
شارك

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

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

تم تعديل بواسطه geme114
اضافة
رابط هذا التعليق
شارك

  • 1 year later...
زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information