عمل اللجان المدرسيه 1

[ناصر سعيد]

بسم الله الرحمن الرحيم

احبابنا في الله

ادعو الله ان تكونوا بخير يارب

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

طريقه الاستفاده من هذا الملف

افتح هذا الملف

اضغط على زر ALT وانت ماتزال ضاغط

اضغط على F11

سيتم فتح محرر الاكواد .. ستجد امامك موديولات بها الاكواد

دبل كليك على الموديول  المعنون Legan_Test

ثم اضغط من لوحة المفاتيح على ALT  +SHEFT 

لتكون اللغه هي العربيه

منعا لظهور اللغه العربيه بشكل طلاسم

اجعل مؤشر الماوس في الكود  ثم اضغط  CTRL +A 

  لتحديد الكود كله

ثم    CTRL+C  ليتم النسخ

=====

** افتح ملفك وافتح محرر الاكواد كما اشرنا  سابقا

** ومن قائمه محرر الاكواد التي فتحت امامك

** اختر Insert  واختر منها Module

** ثم ضع المؤشر في  Module

** والصق الكود

==========

اكتب عدد اللجان التي تبغاها في الخليه G4 في صفحة بيانات الطلبه

وستجد ان امام كل اسم رقم لجنته

لوجود معادلات خاصه بالعالم العلامه عبد الله باقشير

تضبط هذه العمليه

وقد جعلتها واضحه في الصفحه

حتى اضعها تحت الاضواء

ماعليك الا ان تنسخها وتضعها في ملفك في نفس الخلايا

اما اذا اردت تغيير مكانها فلك مطلق الحريه

***  اضغط على زر الزياده والنقصان

***  ثم زر استدعاء كشوف

=========

احمد الله وادعو لكل من له بصمه في اخراج هذا العمل بالخير

يكفي جملة

جزاكم الله خيرا

 

لجان كنترول مدرسي.rar

تم تعديل أكتوبر 24, 2017 بواسطه ناصر سعيد

[ناصر سعيد]

===================

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

=====

رابط اخر

http://gulfup.co/3cshpowij0st

[ناصر سعيد]

Sub Legan_Test()
    Dim Main          As Worksheet
    Dim sh          As Worksheet
    Dim arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim lr          As Long
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long

    Set Main = Sheets("بيانات الطلبة")
    Set sh = Sheets("كشوف المناداة ")

    lr = Main.Cells(Rows.Count, 5).End(xlUp).Row
    
    Application.ScreenUpdating = False
        sh.Range("C10:F39").ClearContents
        sh.Range("K10:N39").ClearContents
        sh.Rows("10:39").Hidden = False
        
        arr = Main.Range("A7:V" & lr).Value
        
        'ارقام الاعمده المطلوب ترحيلها
        arrC = Array(2, 5, 15, 16)
        
        ReDim temp1(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(arr)
        
     'رقم عمود رقم اللجنه في صفحه المصدر
            If arr(i, 18) = sh.Range("E3").Value Then
                p1 = p1 + 1
                For j = 0 To UBound(arrC)
                    temp1(p1, j) = arr(i, arrC(j))
                Next j
            End If
            
     'رقم عمود رقم اللجنه في صفحه المصدر
            If arr(i, 18) = sh.Range("M3").Value Then
                p2 = p2 + 1
                For j = 0 To UBound(arrC)
                    temp2(p2, j) = arr(i, arrC(j))
                Next j
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        If k < 39 Then sh.Rows(k & ":39").Hidden = True
        '===============================
        'بعض التنسيقات في اللجنه
                With ActiveSheet.Range("C10:N39")
            .EntireColumn.NumberFormat = "@"
            .Font.Bold = True
            .ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
        '===============================
        Application.Visible = True
    Application.ScreenUpdating = True
End Sub

 

[ناصر سعيد]

كود المحترم احمد كامل

الخاص بطباعه اللجان

جزاه الله كل خير وبارك فيه .. يارب

Sub طباعة_الكشوف()
  Range("F1").Select
ActiveCell.FormulaR1C1 = "1"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Do
ActiveCell = ActiveCell + 2
Legan_Test
ActiveWindow.SelectedSheets.PrintOut
Loop While ActiveCell.Value <= Range("E1").Value
Range("b1").Select
End Sub

 

[ناصر سعيد]

==============

الملف النهائي

 

 

لجان كنترول مدرسي1.rar

==========

Sub Legan_Test()
'****************
'الكود للمحترم خالد الرشيدي
'وتعديل المحترم ياسر خليل
'الهدف من الكود هو توزيع الطلاب على اللجان المدرسيه
'تم هذا الكود في اكتوبر 2017
'****************
    Dim Main          As Worksheet
    Dim sh          As Worksheet
    Dim arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim lr          As Long
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long

    Set Main = Sheets("بيانات الطلبة")
    Set sh = Sheets("كشوف المناداة ")

    lr = Main.Cells(Rows.Count, 5).End(xlUp).Row
    
    Application.ScreenUpdating = False
        sh.Range("C10:F39").ClearContents
        sh.Range("K10:N39").ClearContents
        sh.Rows("10:39").Hidden = False
        
        arr = Main.Range("A7:V" & lr).Value
        
        'رقم الاعمده المراد ترحيلهافي صفحه المصدر
        arrC = Array(2, 5, 15, 16)
        
        ReDim temp1(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(arr)
        
     'رقم عمود رقم اللجنه للطالب في صفحه المصدر
            If arr(i, 18) = sh.Range("E3").Value Then
            
                p1 = p1 + 1
                For j = 0 To UBound(arrC)
                    temp1(p1, j) = arr(i, arrC(j))
                Next j
            End If
            
                 'رقم عمود رقم اللجنه للطالب في صفحه المصدر
            If arr(i, 18) = sh.Range("M3").Value Then
            
                p2 = p2 + 1
                For j = 0 To UBound(arrC)
                    temp2(p2, j) = arr(i, arrC(j))
                Next j
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        If k < 39 Then sh.Rows(k & ":39").Hidden = True
        '===============================
        'بعض التنسيقات في اللجنه
                With ActiveSheet.Range("C10:N39")
            .EntireColumn.NumberFormat = "@"
            .Font.Bold = True
            .ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
        '===============================
        Application.Visible = True
    Application.ScreenUpdating = True
End Sub

وهذا كود الطباعه

Sub طباعة_الكشوف()
'الكود للمحترم احمد كامل
'الهدف من الكود هو طباعه اللجان المدرسيه
'تم هذا الكود في اكتوبر 2017
'****************

  Range("F1").Select
ActiveCell.FormulaR1C1 = "1"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Do
ActiveCell = ActiveCell + 2
Legan_Test
ActiveWindow.SelectedSheets.PrintOut
Loop While ActiveCell.Value <= Range("E1").Value
Range("b1").Select
End Sub

جزى الله كل من كانت له بصمه في هذا العمل بكل خير